Archive

Archive for June 30, 2019

Porting TextCraft to Oxygene

June 30, 2019 Leave a comment

TextCraft is a simple yet powerful text parser, designed for general purpose parsing jobs. I originally implemented it for Delphi, it’s the base-parser for the LDEF bytecode assembler amongst other things. It was ported to Smart Pascal, then Freepascal – and now finally Oxygene.

ldef

The LDEF Assembler is a part of the Quartex Media Desktop

The LDEF assembler and bytecode engine is currently implemented in Smart and compiles for Javascript. It’s a complete assembler and VM allowing coders to approach Asm.js from an established instruction-set. In short: you feed it source-code, it spits out bytecodes that you can execute super fast in either the browser or elsewhere. As long as there is a VM implementation available.

The Javascript version works really well, especially on node.js. In essence, i don’t need to re-compile the toolchain when moving between arm, x86, windows, linux or osx. Think of it as a type of Java bytecodes or CLR bytecodes.

Getting the code to run under Oxygene, means that I can move the whole engine into WebAssembly. The parser, assembler and linker (et-al) can thus run as WebAssembly, and I can use that from my JavaScript front-end code. Best of both worlds – the flamboyant creativity of JavaScript, and the raw speed of WebAssembly.

The port

Before I can move over the top-level parser + assembler etc, the generic parser code has to work. I was reluctant to start because I imagined the porting would take at least a day, but luckily it took me less than an hour. There are a few superficial differences between Smart, Delphi, Freepascal and Oxygene; for example the Copy() function for strings is not a lose function in Oxygene, instead you use String.SubString(). Functions like High() and Low() on strings likewise has to be refactored.

But all in all the conversion was straight-forward, and TextCraft is now a part of the QTX library for Oxygene. I’ll be uploading a commit to GIT with the whole shabam soon.

Well, hope the WordPress parser doesnt screw this up too bad.

namespace qtxlib;

//##################################################################
// TextCraft 1.2
//  Written by Jon L. Aasenden
//
//  This is a port of TC 1.2 from Freepascal. TextCraft is initially
//  a Delphi parser framework. The original repository can be found
//  on BitBucket at:
//
//  https://bitbucket.org/hexmonks/main
//
//##################################################################

{$DEFINE USE_INCLUSIVE}
{$define USE_BMARK}

interface

uses
  qtxlib, System, rtl,
  RemObjects.Elements.RTL.Delphi,
  RemObjects.Elements.RTL.Delphi.VCL;

type

  // forward declarations
  TTextBuffer         = class;
  TParserContext      = class;
  TCustomParser       = class;
  TParserModelObject  = class;

    // Exceptions
  ETextBuffer   = class(Exception);
  EModelObject  = class(Exception);

  // Callback functions
  TTextValidCB = function (Item: Char): Boolean;

  // Bookmark datatype
  TTextBufferBookmark = class
  public
    property bbOffset: Integer;
    property bbCol:    Integer;
    property bbRow:    Integer;
    function Equals(const ThisMark: TTextBufferBookmark): Boolean;
  end;

  {.$DEFINE USE_BMARK}

  TTextBuffer = class(TErrorObject)
  private
    FData:      String;
    FOffset:    Integer;
    FLength:    Integer;
    FCol:       Integer;
    FRow:       Integer;
    {$IFDEF USE_BMARK}
    FBookmarks: List;
    {$ENDIF}
    procedure   SetCacheData(NewText: String);
  public
    property    Column: Integer read FCol;
    property    Row: Integer read FRow;
    property    Count: Integer read FLength;
    property    Offset: Integer read FOffset;
    property    CacheData: String read FData write SetCacheData;

    // These functions map directly to the "Current"
    // character where the offset is placed, and is used to
    // write code that makes more sense to human eyes
    function    CrLf: Boolean;
    function    Space: Boolean;
    function    Tab: Boolean;
    function    SemiColon: Boolean;
    function    Colon: Boolean;
    function    ConditionEnter: Boolean;
    function    ConditionLeave: Boolean;
    function    BracketEnter: Boolean;
    function    BracketLeave: Boolean;
    function    Ptr: Boolean;
    function    Punctum: Boolean;
    function    Question: Boolean;
    function    Less: Boolean;
    function    More: Boolean;
    function    Equal: Boolean;
    function    Pipe: Boolean;
    function    Numeric: Boolean;

    function    Empty: Boolean;
    function    BOF: Boolean;
    function    EOF: Boolean;
    function    Current: Char;

    function    First: Boolean;
    function    Last: Boolean;

    // Same as "Next", but does not automatically
    // consume CR+LF, used when parsing textfragments
    function    NextNoCrLf: Boolean;

    // Normal Next function, will automatically consume
    // CRLF when it encounters it
    function    Next: Boolean;

    function    Back: Boolean;

    function    Bookmark: TTextBufferBookmark;
    procedure   Restore(const Mark: TTextBufferBookmark);
    {$IFDEF USE_BMARK}
    procedure   Drop;
    {$ENDIF}

    procedure   ConsumeJunk;
    procedure   ConsumeCRLF;

    function    Compare(const CompareText: String;
                const CaseSensitive: Boolean): Boolean;

    function    Read(var Fragment: Char): Boolean; overload;
    function    Read: Char; overload;
    function    ReadTo(const CB: TTextValidCB; var TextRead: String): Boolean; overload;
    function    ReadTo(const Resignators: TSysCharSet; var TextRead: String): Boolean; overload;
    function    ReadTo(MatchText: String): Boolean; overload;
    function    ReadTo(MatchText: String; var TextRead: String): Boolean; overload;

    function    ReadToEOL: Boolean;   overload;
    function    ReadToEOL(var TextRead: String): Boolean;   overload;

    function    Peek: Char; overload;
    function    Peek(CharCount: Integer; var TextRead: String): Boolean; overload;

    function    NextNonControlChar(const CompareWith: Char): Boolean;
    function    NextNonControlText(const CompareWith: String): Boolean;

    function    ReadWord(var TextRead: String): Boolean;

    function    ReadQuotedString: String;
    function    ReadCommaList(var cList: List): Boolean;

    function    NextLine: Boolean;

    procedure   Inject(const TextToInject: String);

    function    GetCurrentLocation: TTextBufferBookmark;

    function    Trail: String;

    procedure   Clear;
    procedure   LoadBufferText(const NewBuffer: String);

    constructor Create(const BufferText: String); overload; virtual;

    finalizer;
    begin
      {$IFDEF USE_BMARK}
      FBookmarks.Clear();
      disposeAndNil(FBookmarks);
      {$endif}
      Clear();
    end;
  end;

  TParserContext = class(TErrorObject)
  private
    FBuffer:    TTextBuffer;
    FStack:     Stack;
  public
    property    Buffer: TTextBuffer read FBuffer;
    property    Model: TParserModelObject;

    procedure   Push(const ModelObj: TParserModelObject);
    function    Pop: TParserModelObject;
    function    Peek: TParserModelObject;
    procedure   ClearStack;

    constructor Create(const SourceCode: String); reintroduce; virtual;

    finalizer;
    begin
      FStack.Clear();
      FBuffer.Clear();
      disposeAndNil(FStack);
      disposeAndNil(FBuffer);
    end;
  end;

  TCustomParser = class(TErrorObject)
  private
    FContext:   TParserContext;
  protected
    procedure   SetContext(const NewContext: TParserContext);
  public
    property    Context: TParserContext read FContext;
    function    Parse: Boolean; virtual;
    constructor Create(const ParseContext: TParserContext); reintroduce; virtual;
  end;

  TParserModelObject = class(TObject)
  private
    FParent:    TParserModelObject;
    FChildren:  List;
  protected
    function    GetParent: TParserModelObject; virtual;
    function    ChildGetCount: Integer; virtual;
    function    ChildGetItem(const Index: Integer): TParserModelObject; virtual;
    function    ChildAdd(const Instance: TParserModelObject): TParserModelObject; virtual;
  public
    property    Parent: TParserModelObject read GetParent;
    property    Context: TParserContext;
    procedure   Clear; virtual;
    constructor Create(const AParent: TParserModelObject); virtual;

    finalizer;
    begin
      Clear();
      FChildren := nil;
    end;

  end;

implementation

//#####################################################################
// Error messages
//#####################################################################

const
  CNT_ERR_BUFFER_EMPTY  = 'Buffer is empty error';
  CNT_ERR_OFFSET_BOF    = 'Offset at BOF error';
  CNT_ERR_OFFSET_EOF    = 'Offset at EOF error';
  CNT_ERR_COMMENT_NOTCLOSED = 'Comment not closed error';
  CNT_ERR_OFFSET_EXPECTED_EOF = 'Expected EOF error';
  CNT_ERR_LENGTH_INVALID = 'Invalid length error';

//#####################################################################
// TTextBufferBookmark
//#####################################################################

function TTextBufferBookmark.Equals(const ThisMark: TTextBufferBookmark): boolean;
begin
  result := ( (ThisMark  nil) and (ThisMark  self) )
        and (self.bbOffset = ThisMark.bbOffset)
        and (self.bbCol = ThisMark.bbCol)
        and (self.bbRow = ThisMark.bbRow);
end;

//#####################################################################
// TTextBuffer
//#####################################################################

constructor TTextBuffer.Create(const BufferText: string);
begin
  inherited Create();
  if length(BufferText) > 0 then
    LoadBufferText(BufferText)
  else
    Clear();
end;

procedure TTextBuffer.Clear;
begin
  FData := '';
  FOffset := -1;
  FLength := 0;
  FCol := -1;
  FRow := -1;
  {$IFDEF USE_BMARK}
  FBookmarks.Clear();
  {$ENDIF}
end;

procedure TTextBuffer.SetCacheData(NewText: string);
begin
  LoadBufferText(NewText);
end;

function TTextBuffer.Trail: string;
begin
  if not Empty then
  begin
    if not EOF then
      result := FData.Substring(FOffset, length(FData) );
      //result := Copy( FData, FOffset, length(FData) );
  end;
end;

procedure TTextBuffer.LoadBufferText(const NewBuffer: string);
begin
  // Flush existing buffer
  Clear();

  // Load in buffertext, init offset and values
  var TempLen := NewBuffer.Length;
  if TempLen > 0 then
  begin
    FData := NewBuffer;
    FOffset := 0; // start at BOF
    FCol := 0;
    FRow := 0;
    FLength := TempLen;
  end;
end;

function TTextBuffer.GetCurrentLocation: TTextBufferBookmark;
begin
  if Failed then
    ClearLastError();
  if not Empty then
  begin
    result := TTextBufferBookmark.Create;
    result.bbOffset := FOffset;
    result.bbCol := FCol;
    result.bbRow := FRow;
  end else
  raise ETextBuffer.Create
  ('Failed to return position, buffer is empty error');
end;

function TTextBuffer.Bookmark: TTextBufferBookmark;
begin
  if Failed then
    ClearLastError();
  if not Empty then
  begin
    result := TTextBufferBookmark.Create;
    result.bbOffset := FOffset;
    result.bbCol := FCol;
    result.bbRow := FRow;
    {$IFDEF USE_BMARK}
    FBookmarks.add(result);
    {$ENDIF}
  end else
  raise ETextBuffer.Create
  ('Failed to bookmark location, buffer is empty error');
end;

procedure TTextBuffer.Restore(const Mark: TTextBufferBookmark);
begin
  if Failed then
    ClearLastError();
  if not Empty then
  begin
    if Mark  nil then
    begin
      FOffset := Mark.bbOffset;
      FCol := Mark.bbCol;
      FRow := Mark.bbRow;
      Mark.Free;

      {$IFDEF USE_BMARK}
      var idx := FBookmarks.Count;
      if idx > 0 then
      begin
        dec(idx);
        FOffset := FBookmarks[idx].bbOffset;
        FCol := FBookmarks[idx].bbCol;
        FRow := FBookmarks[idx].bbRow;
        FBookmarks.Remove(idx);
        //FBookmarks.SetLength(idx)
        //FBookmarks.Delete(idx,1);
      end else
      raise ETextBuffer.Create('Failed to restore bookmark, none exist');
      {$ENDIF}
    end else
    raise ETextBuffer.Create('Failed to restore bookmark, object was nil error');
  end else
  raise ETextBuffer.Create
  ('Failed to restore bookmark, buffer is empty error');
end;

{$IFDEF USE_BMARK}
procedure TTextBuffer.Drop;
begin
  if Failed then
    ClearLastError();
  if not Empty then
  begin
    if FBookmarks.Count > 0 then
      FBookmarks.Remove(FBookmarks.Count-1)
    else
      raise ETextBuffer.Create('Failed to drop bookmark, none exist');
  end else
  raise ETextBuffer.Create
  ('Failed to drop bookmark, buffer is empty error');
end;
{$ENDIF}

function TTextBuffer.Read(var Fragment: char): boolean;
begin
  if Failed then
    ClearLastError();

  if not Empty then
  begin
    result := FOffset <= length(FData);
    if result then
    begin
      // return character
      Fragment := FData[FOffset];

      // update offset
      inc(FOffset)
    end else
    begin
      // return invalid char
      Fragment := #0;

      // Set error reason
      SetLastError('Offset at BOF error');
    end;
  end else
  begin
    result := false;
    Fragment := #0;
    SetLastError('Buffer is empty error');
  end;
end;

function TTextBuffer.Read: char;
begin
  if Failed then
    ClearLastError();

  if not Empty then
  begin
    result := Current;
    Next();
  end else
  result := #0;
end;

function TTextBuffer.ReadToEOL: boolean;
begin
  if Failed then
    ClearLastError();

  if not Empty() then
  begin
    if BOF() then
    begin
      if not First() then
        exit;
    end;

    if EOF() then
    begin
      SetLastError(CNT_ERR_OFFSET_EOF);
      exit;
    end;

    // Keep start
    var LStart := FOffset;

    // Enum until match of EOF
    {$IFDEF USE_INCLUSIVE}
    repeat
      if (FData[FOffset] = #13)
      and (FData[FOffset + 1] = #10) then
      begin
        result := true;
        break;
      end else
      begin
        inc(FOffset);
        inc(FCol);
      end;
    until EOF();
    {$ELSE}
    While FOffset < High(FData) do
    begin
      if (FData[FOffset] = #13)
      and (FData[FOffset + 1] = #10) then
      begin
        result := true;
        break;
      end else
      begin
        inc(FOffset);
        inc(FCol);
      end;
    end;
    {$ENDIF}

    // Last line in textfile might not have
    // a CR+LF, so we have to check for termination
    if not result then
    begin
      if EOF then
      begin
        if LStart = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset <= high(FData) ) )
        and ( (FData[FOffset] = '= Low(FData)) and (FOffset ') );
end;

function  TTextBuffer.Equal: boolean;
begin
  result := (not Empty)
        and ( (FOffset >= Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset  LStart then
        begin
          // Any text to return? Or did we start
          // directly on a CR+LF and have no text to give?
          var LLen := FOffset - LStart;
          TextRead := FData.Substring(LStart, LLen);
          //TextRead := Copy(FData, LStart, LLen);
        end;

        // Either way, we exit because CR+LF has been found
        result := true;
        break;
      end;

      inc(FOffset);
      inc(FCol);
    until EOF();
    {$ELSE}
    While FOffset  LStart then
        begin
          // Any text to return? Or did we start
          // directly on a CR+LF and have no text to give?
          var LLen := FOffset - LStart;
          TextRead := copy(FData, LStart, LLen);
        end;

        // Either way, we exit because CR+LF has been found
        result := true;
        break;
      end;

      inc(FOffset);
      inc(FCol);
    end;
    {$ENDIF}

    // Last line in textfile might not have
    // a CR+LF, so we have to check for EOF and treat
    // that as a terminator.
    if not result then
    begin
      if FOffset >= high(FData) then
      begin
        if LStart  0 then
          begin
            TextRead := FData.Substring(LStart, LLen);
            //TextRead := Copy(FData, LStart, LLen);
            result := true;
          end;
          exit;
        end;
      end;
    end;

  end;
end;

function TTextBuffer.ReadTo(const CB: TTextValidCB; var TextRead: string): boolean;
begin
  if Failed then
    ClearLastError();

  TextRead := '';

  if not Empty then
  begin

    if BOF() then
    begin
      if not First() then
        exit;
    end;

    if EOF() then
    begin
      SetLastError(CNT_ERR_OFFSET_EOF);
      exit;
    end;

    if not assigned(CB) then
    begin
      SetLastError('Invalid callback handler');
      exit;
    end;

    {$IFDEF USE_INCLUSIVE}
    repeat
      if not CB(Current) then
        break
      else
        TextRead := TextRead + Current;

      if not Next() then
        break;
    until EOF();
    {$ELSE}
    while not EOF do
    begin
      if not CB(Current) then
        break
      else
        TextRead := TextRead + Current;

      if not Next() then
        break;
    end;
    {$ENDIF}
    result := TextRead.Length > 0;

  end else
  begin
    result := false;
    SetLastError(CNT_ERR_BUFFER_EMPTY);
  end;
end;

function TTextBuffer.ReadTo(const Resignators: TSysCharSet; var TextRead: string): boolean;
begin
  if Failed then
    ClearLastError();

  TextRead := '';
  if not Empty then
  begin

    if BOF() then
    begin
      if not First() then
        exit;
    end;

    if EOF() then
    begin
      SetLastError(CNT_ERR_OFFSET_EOF);
      exit;
    end;

    {$IFDEF USE_INCLUSIVE}
    repeat
      if not Resignators.Contains(Current) then
        TextRead := TextRead + Current
      else
        break;

      if not Next() then
        break;
    until EOF();
    {$ELSE}
    while not EOF do
    begin
      if not (Current in Resignators) then
        TextRead := TextRead + Current
      else
        break;

      if not Next() then
        break;
    end;
    {$ENDIF}

    result := TextRead.Length > 0;
  end else
  begin
    result := false;
    SetLastError(CNT_ERR_BUFFER_EMPTY);
  end;
end;

function TTextBuffer.ReadTo(MatchText: string): boolean;
begin
  if Failed then
    ClearLastError();

  if not Empty() then
  begin

    if BOF() then
    begin
      if not First() then
        exit;
    end;

    if EOF() then
    begin
      SetLastError(CNT_ERR_OFFSET_EOF);
      exit;
    end;

    var MatchLen := length(MatchText);
    if MatchLen > 0 then
    begin
      MatchText := MatchText.ToLower();

      repeat
        var TempCache := '';
        if Peek(MatchLen, TempCache) then
        begin
          TempCache := TempCache.ToLower();
          result := SameText(TempCache, MatchText);
          if result then
            break;
        end;

        if not Next then
          break;
      until EOF;
    end;

  end else
  begin
    result := false;
    SetLastError(CNT_ERR_BUFFER_EMPTY);
  end;
end;

function TTextBuffer.ReadTo(MatchText: string; var TextRead: string): boolean;
begin
  if Failed then
    ClearLastError();

  result := false;
  TextRead := '';

  if not Empty() then
  begin

    if BOF() then
    begin
      if not First() then
        exit;
    end;

    if EOF() then
    begin
      SetLastError(CNT_ERR_OFFSET_EOF);
      exit;
    end;

    if MatchText.Length > 0 then
    begin
      MatchText := MatchText.ToLower();

      repeat
        var TempCache := '';
        if Peek(MatchText.Length, TempCache) then
        begin
          TempCache := TempCache.ToLower();
          result := SameText(TempCache, MatchText);
          if result then
            break
          else
            TextRead := TextRead + Current;
        end else
          TextRead := TextRead + Current;

        if not Next() then
          break;
      until EOF;
    end;

  end else
  begin
    result := false;
    SetLastError(CNT_ERR_BUFFER_EMPTY);
  end;
end;

procedure TTextBuffer.Inject(const TextToInject: string);
begin
  if length(FData) > 0 then
  begin
    var lSeg1 := FData.Substring(1, FOffset);
    var lSeg2 := FData.Substring(FOffset + 1, length(FData));
    //var LSeg1 := Copy(FData, 1, FOffset);
    //var LSeg2 := Copy(FData, FOffset+1,  FData.Length);
    FData := lSeg1 + TextToInject + lSeg2;
  end else
    FData := TextToInject;
end;

function TTextBuffer.Compare(const CompareText: string;
    const CaseSensitive: boolean): boolean;
begin
  if Failed then
    ClearLastError();

  if not Empty() then
  begin
    if BOF() then
    begin
      if not First() then
        exit;
    end;

    if EOF() then
    begin
      SetLastError(CNT_ERR_OFFSET_EOF);
      exit;
    end;

    var LenToRead := CompareText.Length;
    if LenToRead > 0 then
    begin
      // Peek will set an error message if it
      // fails, so we dont need to set anything here
      var ReadData := '';
      if Peek(LenToRead, ReadData) then
      begin
        case CaseSensitive of
        false: result := ReadData.ToLower() = CompareText.ToLower();
        true:  result := ReadData = CompareText;
        end;
      end;
    end else
    SetLastError(CNT_ERR_LENGTH_INVALID);

  end else
  SetLastError(CNT_ERR_BUFFER_EMPTY);
end;

procedure TTextBuffer.ConsumeJunk;
begin
  if Failed then
    ClearLastError();

  if not Empty then
  begin

    if BOF() then
    begin
      if not First() then
        exit;
    end;

    if EOF() then
    begin
      SetLastError(CNT_ERR_OFFSET_EOF);
      exit;
    end;

    repeat
      case Current of
      ' ':
        begin
        end;
      '"':
        begin
          break;
        end;
      #8, #09:
        begin
        end;
      '/':
        begin
          (* Skip C style remark *)
          if Compare('/*', false) then
          begin
            if ReadTo('*/') then
            begin
              inc(FOffset, 2);
              Continue;
            end else
            SetLastError(CNT_ERR_COMMENT_NOTCLOSED);
          end else
          begin
            (* Skip Pascal style remark *)
            if Compare('//', false) then
            begin
              if ReadToEOL() then
              begin
                continue;
              end else
              SetLastError(CNT_ERR_OFFSET_EXPECTED_EOF);
            end;
          end;
        end;
      '(':
        begin
          (* Skip pascal style remark *)
          if Compare('(*', false)
            and not Compare('(*)', false) then
          begin
            if ReadTo('*)') then
            begin
              inc(FOffset, 2);
              continue;
            end else
            SetLastError(CNT_ERR_COMMENT_NOTCLOSED);
          end else
          break;
        end;
      #13:
        begin
          if FData[FOffset + 1] = #10 then
            inc(FOffset, 2)
          else
            inc(FOffset, 1);
          //if Peek = #10 then
          //  ConsumeCRLF;
          continue;
        end;
      #10:
        begin
          inc(FOffset);
          continue;
        end;
      else
        break;
      end;

      if not Next() then
        break;
    until EOF;

  end else
  SetLastError(CNT_ERR_BUFFER_EMPTY);
end;

procedure TTextBuffer.ConsumeCRLF;
begin
  if not Empty then
  begin

    if BOF() then
    begin
      if not First() then
        exit;
    end;

    if EOF() then
    begin
      SetLastError(CNT_ERR_OFFSET_EOF);
      exit;
    end;

    if  (FData[FOffset] = #13) then
    begin
      if FData[FOffset + 1] = #10 then
        inc(FOffset, 2)
      else
        inc(FOffset);

      inc(FRow);
      FCol := 0;
    end;

  end;
end;

function TTextBuffer.Empty: boolean;
begin
  result := FLength < 1;
end;

// This method will look ahead, skipping space, tab and crlf (also known
// as control characters), and when a non control character is found it will
// perform a string compare. This method uses a bookmark and will restore
// the offset to the same position as when it was entered.
//
// Notes: The method "NextNonControlChar" is a similar method that
// performs a char-only compare.
function TTextBuffer.NextNonControlText(const CompareWith: string): boolean;
begin
  if Failed then
    ClearLastError();

  if not Empty then
  begin

    if BOF() then
    begin
      if not First() then
        exit;
    end;

    if EOF() then
    begin
      SetLastError(CNT_ERR_OFFSET_EOF);
      exit;
    end;

    var Mark := Bookmark();
    try
      // Iterate ahead
      repeat
        if not (Current in [' ', #13, #10, #09]) then
          break;

        Next();
      until EOF();

      // Compare unless we hit the end of the line
      if not EOF then
        result := Compare(CompareWith, false);
    finally
      Restore(Mark);
    end;

  end else
  SetLastError(CNT_ERR_BUFFER_EMPTY);
end;

// This method will look ahead, skipping space, tab and crlf (also known
// as control characters), and when a non control character is found it will
// perform a string compare. This method uses a bookmark and will restore
// the offset to the same position as when it was entered.

function TTextBuffer.NextNonControlChar(const CompareWith: char): boolean;
begin
  if Failed then
    ClearLastError();

  if not Empty then
  begin
    if BOF() then
    begin
      if not First() then
        exit;
    end;

    if EOF() then
    begin
      SetLastError(CNT_ERR_OFFSET_EOF);
      exit;
    end;

    var Mark := Bookmark();
    try
      repeat
        if not (Current in [' ', #13, #10, #09]) then
          break;
        Next();
      until EOF();

      //if not EOF then
      result := Current.ToLower() = CompareWith.ToLower();
      //result := LowerCase(Current) = LowerCase(CompareWith);

    finally
      Restore(Mark);
    end;

  end else
  SetLastError(CNT_ERR_BUFFER_EMPTY);
end;

function TTextBuffer.Peek: char;
begin
  if Failed then
    ClearLastError();
  if not Empty then
  begin
    if (FOffset  0 do
        begin
          TextRead := TextRead + Current;
          if not Next() then
            break;
          dec(CharCount);
        end;
      finally
        Restore(Mark);
      end;

      result := TextRead.Length > 0;

    end else
    SetLastError(CNT_ERR_OFFSET_EOF);
  end else
  SetLastError(CNT_ERR_BUFFER_EMPTY);
end;

function TTextBuffer.First: boolean;
begin
  if Failed then
    ClearLastError();

  if not Empty then
  begin
    FOffset := Low(FData);
    result := true;
  end else
  SetLastError(CNT_ERR_BUFFER_EMPTY);
end;

function TTextBuffer.Last: boolean;
begin
  if Failed then
    ClearLastError();

  if not Empty then
  begin
    FOffset := high(FData);
    result := true;
  end else
  SetLastError(CNT_ERR_BUFFER_EMPTY);
end;

function TTextBuffer.NextNoCrLf: boolean;
begin
  if Failed then
    ClearLastError();

  if not Empty then
  begin
    // Check that we are not EOF
    result := FOffset <= high(FData);
    if result then
    begin
      // Update offset into buffer
      inc(FOffset);

      // update column, but not if its in a lineshift
      if not (FData[FOffset] in [#13, #10]) then
        inc(FCol);

    end else
    SetLastError(CNT_ERR_OFFSET_EOF);
  end else
  SetLastError(CNT_ERR_BUFFER_EMPTY);
end;

function TTextBuffer.Next: boolean;
begin
  if Failed then
    ClearLastError();

  if not Empty() then
  begin

    if BOF() then
    begin
      if not First() then
        exit;
    end;

    if EOF() then
    begin
      SetLastError(CNT_ERR_OFFSET_EOF);
      exit;
    end;

    // Update offset into buffer
    inc(FOffset);

    // update column
    inc(FCol);

    // This is the same as ConsumeCRLF
    // But this does not generate any errors since we PEEK
    // ahead into the buffer to make sure the combination
    // is correct before we adjust the ROW + offset
    if FOffset  Low(FData));
    if result then
      dec(FOffset)
    else
      SetLastError(CNT_ERR_OFFSET_BOF);
  end else
  SetLastError(CNT_ERR_BUFFER_EMPTY);
end;

function TTextBuffer.Current: char;
begin
  if Failed then
    ClearLastError();

  // Check that buffer is not empty
  if not Empty then
  begin
    // Check that we are on char 1 or more
    if FOffset >= Low(FData) then
    begin
      // Check that we are before or on the last char
      if (FOffset <= high(FData)) then
        result := FData[FOffset]
      else
      begin
        SetLastError(CNT_ERR_OFFSET_EOF);
        result := #0;
      end;
    end else
    begin
      SetLastError(CNT_ERR_OFFSET_BOF);
      result := #0;
    end;
  end else
  begin
    SetLastError(CNT_ERR_BUFFER_EMPTY);
    result := #0;
  end;
end;

function TTextBuffer.BOF: boolean;
begin
  if not Empty then
    result := FOffset  high(FData);
end;

function TTextBuffer.NextLine: boolean;
begin
  if Failed then
    ClearLastError();

  if not Empty then
  begin
    // Make sure we offset to a valid character
    // in the buffer.
    ConsumeJunk();

    if not EOF then
    begin
      var ThisRow := self.FRow;
      while Row = ThisRow do
      begin
        Next();
        if EOF then
        break;
      end;

      result := (Row  ThisRow) and (not EOF);
    end;
  end;
end;

function TTextBuffer.ReadWord(var TextRead: string): boolean;
begin
  if Failed then
    ClearLastError();

  TextRead := '';

  if not Empty then
  begin
    // Make sure we offset to a valid character
    // in the buffer.
    ConsumeJunk();

    // Not at the end of the file?
    if not EOF then
    begin
      repeat
        var el := Current;

        if (el in
        [ 'A'..'Z',
          'a'..'z',
          '0'..'9',
          '_', '-' ]) then
          TextRead := TextRead + el
        else
          break;

        if not NextNoCrLf() then
          break;

      until EOF;

      result := TextRead.Length > 0;

    end else
    SetLastError('Failed to read word, unexpected EOF');
  end else
  SetLastError('Failed to read word, buffer is empty error');
end;

function TTextBuffer.ReadCommaList(var cList: List): boolean;
var
  LTemp: String;
  LValue: String;
begin
  if cList = nil then
    cList := new List
  else
    cList.Clear();

  if not Empty then
  begin
    ConsumeJunk();

    While not EOF do
    begin
      case Current of
      #09:
        begin
          // tab, just skip
        end;
      #13, #10:
        begin
          // CR+LF, consume and continue;
          ConsumeCRLF();
        end;
      #0:
        begin
          // Unexpected EOL
          break;
        end;

      ';':
        begin
          //Perfectly sound ending
          result := true;
          break;
        end;
      '"':
        begin
          LValue := ReadQuotedString;
          if LValue.Length > 0 then
          begin
            cList.add(LValue);
            LValue := '';
          end;
        end;
      ',':
        begin
          LTemp := LTemp.Trim();
          if LTemp.Length>0 then
          begin
            cList.add(LTemp);
            LTemp := '';
          end;
        end;
      else
        begin
          LTemp := LTemp + Current;
        end;
      end;

      if not Next() then
        break;
    end;

    if LTemp.Length > 0 then
      cList.add(LTemp);

    result := cList.Count > 0;

  end;
end;

function TTextBuffer.ReadQuotedString: string;
begin
  if not Empty then
  begin
    if not EOF then
    begin

      // Make sure we are on the " entry quote
      if Current  '"' then
      begin
        SetLastError('Failed to read quoted string, expected index on " character error');
        exit;
      end;

      // Skip the entry char
      if not NextNoCrLf() then
      begin
        SetLastError('Failed to skip initial " character error');
        exit;
      end;

      while not EOF do
      begin
        // Read char from buffer
        var TempChar := Current;

        // Closing of string? Exit
        if TempChar = '"' then
        begin
          if not NextNoCrLf then
            SetLastError('failed to skip final " character in string error');
          break;
        end;

        result := result + TempChar;

        if not NextNoCrLf() then
          break;
      end;

    end;
  end;
end;

//##########################################################################
// TParserModelObject
//##########################################################################

constructor TParserModelObject.Create(const AParent:TParserModelObject);
begin
  inherited Create;
  FParent := AParent;
  FChildren := new List;
end;

function TParserModelObject.GetParent:TParserModelObject;
begin
  result := FParent;
end;

procedure TParserModelObject.Clear;
begin
  FChildren.Clear();
end;

function TParserModelObject.ChildGetCount: integer;
begin
  result := FChildren.Count;
end;

function TParserModelObject.ChildGetItem(const Index: integer): TParserModelObject;
begin
  result := TParserModelObject(FChildren[Index]);
end;

function TParserModelObject.ChildAdd(const Instance: TParserModelObject): TParserModelObject;
begin
  if FChildren.IndexOf(Instance) < 0 then
    FChildren.add(Instance);
  result := Instance;
end;

//###########################################################################
// TParserContext
//###########################################################################

constructor TParserContext.Create(const SourceCode: string);
begin
  inherited Create;
  FBuffer := TTextBuffer.Create(SourceCode);
  FStack := new Stack;
end;

procedure TParserContext.Push(const ModelObj: TParserModelObject);
begin
  if Failed then
    ClearLastError();

  try
    FStack.Push(ModelObj);
  except
    on e: Exception do
    SetLastError('Internal error:' + e.Message);
  end;
end;

function TParserContext.Pop: TParserModelObject;
begin
  if Failed then
    ClearLastError();
  try
    result := FStack.Pop();
  except
    on e: Exception do
    SetLastError('Internal error:' + e.Message);
  end;
end;

function TParserContext.Peek: TParserModelObject;
begin
  if Failed then
    ClearLastError();
  try
    result := FStack.Peek();
  except
    on e: Exception do
    SetLastError('Internal error:' + e.Message);
  end;
end;

procedure TParserContext.ClearStack;
begin
  if Failed then
    ClearLastError();
  try
    FStack.Clear();
  except
    on e: Exception do
    SetLastError('Internal error:' + e.Message);
  end;
end;

//###########################################################################
// TCustomParser
//###########################################################################

constructor TCustomParser.Create(const ParseContext: TParserContext);
begin
  inherited Create;
  FContext := ParseContext;
end;

function TCustomParser.Parse: boolean;
begin
  result := false;
  SetLastErrorF('No parser implemented for class %s',[ClassName]);
end;

procedure TCustomParser.SetContext(const NewContext: TParserContext);
begin
  FContext := NewContext;
end;

end.

Generic protect for FPC/Lazarus

June 30, 2019 Leave a comment

Freepascal is not frequently mentioned on my blog. I have written about it from time to time, not always in a positive light though. Just to be clear, FPC (the compiler) is fantastic; it was one particular fork of Lazarus I had issues with, involving a license violation.

On the whole, freepascal and Lazarus is capable of great things. There are a few quirks here and there (if not oddities) that prevents mass adoption (the excessive use of include-files to “fake” partial classes being one), but as object-pascal compilers go, Freepascal is a battle-hardened, production ready system.

It’s been Linux in particular that I have used Freepascal on. In 2015 Hydro Oil wanted to move their back-end from Windows to Linux, and I spent a few months converting windows-only services into Linux daemons.

Today I find myself converting parts of the toolkit I came up with to Oxygene, but that’s a post for another day.

Generic protect

If you work a lot with multithreaded code, the unit im posting here might come in handy. Long story short: sharing composite objects between threads and the main process, always means extra scaffolding. You have to make sure you don’t access the list (or it’s elements) at the same time as another thread for example. To ensure this you can either use a critical-section, or you can deliver the data with a synchronized call. This is more or less universal for all languages, no matter if you are using Oxygene, C/C++, C# or Delphi.

When this unit came into being, I was doing quite elaborate classes with a lot of lists. These classes could not share ancestor, or I could have gotten away with just one locking mechanism. Instead I had to implement the same boilerplate code over and over again.

The unit below makes insulating (or protecting) classes easier. It essentially envelopes whatever class-instance you feed it, and returns the proxy object. Whenever you want to access your instance, you have to unlock it first or use a synchronizer (see below).

Works in both Freepascal and Delphi

The unit works for both Delphi and Freepascal, but there is one little difference. For some reason Freepascal does not support anonymous procedures, so we compensate and use inline-procedures instead. While not a huge deal, I really hope the FPC team add anonymous procedures, it makes life a lot easier for generics based code. Async programming without anonymous procedures is highly impractical too.

So if you are in Delphi you can write:

var
 lValue: TProtectedValue;
 lValue.Synchronize( procedure (var Value: integer)
 begin
   Value := Value * 12;
 end);

But under Freepascal you must resort to:

var
 lValue: TProtectedValue;

procedure _UpdateValue(var Data: integer);
begin
 Data := Data * 12;
end;

begin
  lValue.Synchronize(@_UpdateValue);
end;

On small examples like these, the benefit of this style of coding might be lost; but if you suddenly have 40-50 lists that needs to be shared between 100-200 active threads, it will be a time saver!

You can also use it on intrinsic datatypes:

lazarus

OK, here we go:

unit safeobjects;

// 	SafeObjects
//	==========================================================================
//	Written by Jon-Lennart Aasenden
//	Copyright Quartex Components LTD, all rights reserved
//
//	This unit is a part of the QTX Patreon Library
//
//	NOTES ABOUT FREEPASCAL:
//	=======================
//	Freepascal does not allow anonymous procedures, which means we must
//	resort to inline procedures instead:
//
// 	Where we in Delphi could write the following for an atomic,
//	thread safe alteration:
//
// var
// 	LValue: TProtectedValue;
//
//	LValue.Synchronize( procedure (var Value: integer)
//	begin
//		Value := Value * 12;
//	end);
//
//	Freepascal demands that we use an inline procedure instead, which
//  is more or less the same code, just organized slightly differently.
//
// var
// 	LValue: TProtectedValue;
//
//  procedure _UpdateValue(var Data: integer);
//  begin
//  	Data := Data * 12;
//  end;
//
// begin
//	LValue.Synchronize(@_UpdateValue);
// end;
//
//
//
//

{$mode DELPHI}
{$H+}

interface

uses
  {$IFDEF FPC}
  SysUtils,
  Classes,
  SyncObjs,
  Generics.Collections;
	{$ELSE}
  System.SysUtils,
  System.Classes,
  System.SyncObjs,
  System.Generics.Collections;
  {$ENDIF}

type

  {$DEFINE INHERIT_FROM_CRITICALSECTION}

  TProtectedValueAccessRights = set of (lvRead, lvWrite);

  EProtectedValue = class(exception);
  EProtectedObject = class(exception);

  (* Thread safe intrinsic datatype container.
     When sharing values between processes, use this class
     to make read/write access safe and protected. *)

  {$IFDEF INHERIT_FROM_CRITICALSECTION}
  TProtectedValue = class(TCriticalSection)
  {$ELSE}
  TProtectedValue = class(TObject)
  {$ENDIF}
  strict private
    {$IFNDEF INHERIT_FROM_CRITICALSECTION}
    FLock: TCriticalSection;
    {$ENDIF}
    FData: T;
    FOptions: TProtectedValueAccessRights;
  strict protected
    function GetValue: T;virtual;
    procedure SetValue(Value: T);virtual;
    function GetAccessRights: TProtectedValueAccessRights;
    procedure SetAccessRights(Rights: TProtectedValueAccessRights);
  public
    type
  		{$IFDEF FPC}
      TProtectedValueEntry = procedure (var Data: T);
  		{$ELSE}
      TProtectedValueEntry = reference to procedure (var Data: T);
      {$ENDIF}
  public
    constructor Create(Value: T); overload; virtual;
    constructor Create(Value: T; const Access: TProtectedValueAccessRights); overload; virtual;
    constructor Create(const Access: TProtectedValueAccessRights); overload; virtual;
    destructor Destroy;override;

    {$IFNDEF INHERIT_FROM_CRITICALSECTION}
    procedure Enter;
    procedure Leave;
    {$ENDIF}
    procedure Synchronize(const Entry: TProtectedValueEntry);

    property AccessRights: TProtectedValueAccessRights read GetAccessRights;
    property Value: T read GetValue write SetValue;
  end;

  (* Thread safe object container.
     NOTE #1: This object container **CREATES** the instance and maintains it!
              Use Edit() to execute a protected block of code with access
              to the object.

     Note #2: SetValue() does not overwrite the object reference, but
              attempts to perform TPersistent.Assign(). If the instance
              does not inherit from TPersistent an exception is thrown. *)
  TProtectedObject = class(TObject)
  strict private
    FData:      T;
    FLock:      TCriticalSection;
    FOptions:   TProtectedValueAccessRights;
  strict protected
    function    GetValue: T;virtual;
    procedure   SetValue(Value: T);virtual;
    function    GetAccessRights: TProtectedValueAccessRights;
    procedure   SetAccessRights(Rights: TProtectedValueAccessRights);
  public
    type
			{$IFDEF FPC}
      TProtectedObjectEntry = procedure (const Data: T);
	    {$ELSE}
      TProtectedObjectEntry = reference to procedure (const Data: T);
      {$ENDIF}
  public
    property    Value: T read GetValue write SetValue;
    property    AccessRights: TProtectedValueAccessRights read GetAccessRights;

    function    Lock: T;
    procedure   Unlock;
    procedure   Synchronize(const Entry: TProtectedObjectEntry);

    Constructor Create(const AOptions: TProtectedValueAccessRights = [lvRead,lvWrite]); virtual;
    Destructor  Destroy; override;
  end;

  (* TProtectedObjectList:
     This is a thread-safe object list implementation.
     It works more or less like TThreadList, except it deals with objects *)
  TProtectedObjectList = class(TInterfacedPersistent)
  strict private
    FObjects: TObjectList;
    FLock: TCriticalSection;
  strict protected
    function GetEmpty: boolean;virtual;
    function GetCount: integer;virtual;

    (* QueryObject Proxy: TInterfacedPersistent allows us to
       act as a proxy for QueryInterface/GetInterface. Override
       and provide another child instance here to expose
       interfaces from that instread *)
  protected
    function GetOwner: TPersistent;override;

  public
    type
      {$IFDEF FPC}
      TProtectedObjectListProc = procedure (Item: TObject; var Cancel: boolean);
      {$ELSE}
      TProtectedObjectListProc = reference to procedure (Item: TObject; var Cancel: boolean);
      {$ENDIF}
  public
    constructor Create(OwnsObjects: Boolean = true); virtual;
    destructor  Destroy; override;

    function    Contains(Instance: TObject): boolean; virtual;
    function    Enter: TObjectList; virtual;
    Procedure   Leave; virtual;
    Procedure   Clear; virtual;

    procedure   ForEach(const CB: TProtectedObjectListProc); virtual;

    Property    Count: integer read GetCount;
    Property    Empty: boolean read GetEmpty;
  end;

implementation

//############################################################################
//  TProtectedObjectList
//############################################################################

constructor TProtectedObjectList.Create(OwnsObjects: Boolean = True);
begin
  inherited Create;
  FObjects := TObjectList.Create(OwnsObjects);
  FLock := TCriticalSection.Create;
end;

destructor TProtectedObjectList.Destroy;
begin
  FLock.Enter;
  FObjects.Free;
  FLock.Free;
  inherited;
end;

procedure TProtectedObjectList.Clear;
begin
  FLock.Enter;
  try
    FObjects.Clear;
  finally
    FLock.Leave;
  end;
end;

function TProtectedObjectList.GetOwner: TPersistent;
begin
  result := NIL;
end;

procedure TProtectedObjectList.ForEach(const CB: TProtectedObjectListProc);
var
  LItem:  TObject;
  LCancel:  Boolean;
begin
	LCancel := false;
  if assigned(CB) then
  begin
    FLock.Enter;
    try
    	{$HINTS OFF}
      for LItem in FObjects do
      begin
        LCancel := false;
        CB(LItem, LCancel);
        if LCancel then
        	break;
      end;
      {$HINTS ON}
    finally
      FLock.Leave;
    end;
  end;
end;

function TProtectedObjectList.Contains(Instance: TObject): boolean;
begin
  result := false;
  if assigned(Instance) then
  begin
    FLock.Enter;
    try
      result := FObjects.Contains(Instance);
    finally
      FLock.Leave;
    end;
  end;
end;

function TProtectedObjectList.GetCount: integer;
begin
  FLock.Enter;
  try
    result :=FObjects.Count;
  finally
    FLock.Leave;
  end;
end;

function TProtectedObjectList.GetEmpty: Boolean;
begin
  FLock.Enter;
  try
    result := FObjects.Count<1;
  finally
    FLock.Leave;
  end;
end;

function TProtectedObjectList.Enter: TObjectList;
begin
  FLock.Enter;
  result := FObjects;
end;

procedure TProtectedObjectList.Leave;
begin
  FLock.Leave;
end;

//############################################################################
//  TProtectedObject
//############################################################################

constructor TProtectedObject.Create(const AOptions: TProtectedValueAccessRights = [lvRead, lvWrite]);
begin
  inherited Create;
  FLock := TCriticalSection.Create;
  FLock.Enter();
  try
  	FOptions := AOptions;
  	FData := T.Create;
  finally
    FLock.Leave();
  end;
end;

destructor TProtectedObject.Destroy;
begin
	FData.free;
  FLock.Free;
  inherited;
end;

function TProtectedObject.GetAccessRights: TProtectedValueAccessRights;
begin
  FLock.Enter;
  try
    result := FOptions;
  finally
    FLock.Leave;
  end;
end;

procedure TProtectedObject.SetAccessRights(Rights: TProtectedValueAccessRights);
begin
  FLock.Enter;
  try
    FOptions := Rights;
  finally
    FLock.Leave;
  end;
end;

function TProtectedObject.Lock: T;
begin
  FLock.Enter;
  result := FData;
end;

procedure TProtectedObject.Unlock;
begin
  FLock.Leave;
end;

procedure TProtectedObject.Synchronize(const Entry: TProtectedObjectEntry);
begin
  if assigned(Entry) then
  begin
    FLock.Enter;
    try
      Entry(FData);
    finally
      FLock.Leave;
    end;
  end;
end;

function TProtectedObject.GetValue: T;
begin
  FLock.Enter;
  try
    if (lvRead in FOptions) then
    	result := FData
  	else
    	raise EProtectedObject.CreateFmt('%s:Read not allowed error',[classname]);
  finally
    FLock.Leave;
  end;
end;

procedure TProtectedObject.SetValue(Value: T);
begin
  FLock.Enter;
  try
    if (lvWrite in FOptions) then
    begin
      if (TObject(FData) is TPersistent)
      or (TObject(FData).InheritsFrom(TPersistent)) then
      	TPersistent(FData).Assign(TPersistent(Value))
    	else
      	raise EProtectedObject.CreateFmt
        	('Locked object assign failed, %s does not inherit from %s',
        	[TObject(FData).ClassName,'TPersistent']);

    end else
    raise EProtectedObject.CreateFmt('%s:Write not allowed error',[classname]);
  finally
    FLock.Leave;
  end;
end;

//############################################################################
//  TProtectedValue
//############################################################################

Constructor TProtectedValue.Create(const Access: TProtectedValueAccessRights);
begin
  inherited Create;
  {$IFNDEF INHERIT_FROM_CRITICALSECTION}
  FLock := TCriticalSection.Create;
  {$ENDIF}
  FOptions := Access;
end;

constructor TProtectedValue.Create(Value: T);
begin
  inherited Create;
  {$IFNDEF INHERIT_FROM_CRITICALSECTION}
  FLock := TCriticalSection.Create;
  {$ENDIF}
  FOptions := [lvRead, lvWrite];
  FData := Value;
end;

constructor TProtectedValue.Create(Value: T; const Access: TProtectedValueAccessRights);
begin
  inherited Create;
  {$IFNDEF INHERIT_FROM_CRITICALSECTION}
  FLock := TCriticalSection.Create;
  {$ENDIF}
  FOptions := Access;
  FData := Value;
end;

Destructor TProtectedValue.Destroy;
begin
  {$IFNDEF INHERIT_FROM_CRITICALSECTION}
  FLock.Free;
  {$ENDIF}
  inherited;
end;

function TProtectedValue.GetAccessRights: TProtectedValueAccessRights;
begin
  Enter();
  try
    result := FOptions;
  finally
    Leave();
  end;
end;

procedure TProtectedValue.SetAccessRights(Rights: TProtectedValueAccessRights);
begin
  Enter();
  try
    FOptions := Rights;
  finally
    Leave();
  end;
end;

{$IFNDEF INHERIT_FROM_CRITICALSECTION}
procedure TProtectedValue.Enter;
begin
  FLock.Enter;
end;

procedure TProtectedValue.Leave;
begin
  FLock.Leave;
end;
{$ENDIF}

procedure TProtectedValue.Synchronize(const Entry: TProtectedValueEntry);
begin
  if assigned(Entry) then
  Begin
    Enter();
    try
      Entry(FData);
    finally
      Leave();
    end;
  end;
end;

function TProtectedValue.GetValue: T;
begin
  Enter();
  try
    if (lvRead in FOptions) then
    	result := FData
    else
    	raise EProtectedValue.CreateFmt('%s: Read not allowed error', [Classname]);
  finally
    Leave();
  end;
end;

procedure TProtectedValue.SetValue(Value: T);
begin
  Enter();
  try
    if (lvWrite in FOptions) then
    	FData:=Value
    else
    	raise EProtectedValue.CreateFmt('%s: Write not allowed error', [Classname]);
  finally
    Leave();
  end;
end;

end.