{
            Copyright (C) 2014 Doj <vitek03@gmail.com>

This code is free software. It comes without any warranty, to the extent
permitted by applicable law. You can redistribute it and/or modify it under
the terms of the Do What The Fuck You Want To Public License, Version 2,
as published by Sam Hocevar. See the full text below for more details or
visit http://www.wtfpl.net/ website.

           DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
                   Version 2, December 2004

         Copyright (C) 2004 Sam Hocevar <sam@hocevar.net>

Everyone is permitted to copy and distribute verbatim or modified
copies of this license document, and changing it is allowed as long
as the name is changed.

           DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
  TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION

 0. You just DO WHAT THE FUCK YOU WANT TO.
}
{$IFDEF FPC}{$MODE DELPHI}{$ENDIF}
unit protobuf;

interface

type
  TSerializeFunc = function (Data: Pointer; Size: LongInt): LongInt;// is nested;
  TParseFunc = function (Data: Pointer; Size: LongInt): LongInt;// is nested;

// FIXME inside TProtobuf I got errors:
//descriptor_pb.o:(.data+0x37ca): undefined reference to `RTTI_PROTOBUF_DEF11'
//protoc-gen-pascal.pp(43) Error: Error while linking
//protoc-gen-pascal.pp(43) Fatal: There were 1 errors compiling module, stopping
  TBytes = array of Byte;

TProtoMessageObject = object
private
  FCachedSize: SizeInt;
protected
  procedure ComputeSize; virtual; abstract;
  procedure DoSerialize(Func: TSerializeFunc); virtual; abstract;
  procedure DoParse(Func: TParseFunc); virtual; abstract;
  property Size: SizeInt read FCachedSize;
public
  procedure Serialize(Func: TSerializeFunc);
  procedure Parse(Func: TParseFunc);
end;
  
TProtobuf = object
public type
  TErrorHandler = procedure (Id: Integer; const Msg: AnsiString);

public const
  WIRE_VARINT           = 0;
  WIRE_64BIT            = 1;
  WIRE_LENGTH_DELIMITED = 2;
  WIRE_START_GROUP      = 3; // deprecated
  WIRE_END_GROUP        = 4; // deprecated
  WIRE_32BIT            = 5;

public
  function ParseVarint(Func: TParseFunc): LongInt; static;
  procedure ParseHeader(Func: TParseFunc; out Wire, Index: Integer); overload; static; inline;
  procedure ParseDouble(Func: TParseFunc; out Value: Double); static; inline;
  procedure ParseFloat(Func: TParseFunc; out Value: Single); static; inline;
  procedure ParseInt64(Func: TParseFunc; out Value: Int64); static; inline;
  procedure ParseUInt64(Func: TParseFunc; out Value: QWord); static; inline;
  procedure ParseInt32(Func: TParseFunc; out Value: LongInt); static; inline;
  //procedure ParseFixed64(Func: TParseFunc; out Value: Fixed64); static; inline;
  //procedure ParseFixed32(Func: TParseFunc; out Value: Fixed32); static; inline;
  procedure ParseBool(Func: TParseFunc; out Value: Boolean); static; inline;
  procedure ParseString(Func: TParseFunc; out Value: AnsiString); overload; static; inline;
  procedure ParseMessage(Func: TParseFunc; out Value: TProtoMessageObject); overload; static; inline;
  procedure ParseBytes(Func: TParseFunc; out Value: TBytes); static; inline;
  procedure ParseUInt32(Func: TParseFunc; out Value: Cardinal); static; inline;
  procedure ParseEnum(Func: TParseFunc; out Value: Byte); overload; static; inline;
  procedure ParseEnum(Func: TParseFunc; out Value: Word); overload; static; inline;
  procedure ParseEnum(Func: TParseFunc; out Value: Cardinal); overload; static; inline;
  //procedure ParseSFixed32(Func: TParseFunc; out Value: SFixed32); static; inline;
  //procedure ParseSFixed64(Func: TParseFunc; out Value: SFixed64); static; inline;
  procedure ParseSInt32(Func: TParseFunc; out Value: LongInt); static; inline;
  procedure ParseSInt64(Func: TParseFunc; out Value: QWord); static; inline;
  procedure ParseSkip(Func: TParseFunc; Count: Integer); static;
  procedure ParseSkipValue(Func: TParseFunc; Wire: Integer); static;
  procedure SerializeVarint(Func: TSerializeFunc; Value: LongInt); overload; static; inline;
  procedure SerializeVarint(Func: TSerializeFunc; Value: Int64); overload; static; inline;
  procedure SerializeHeader(Func: TSerializeFunc; Wire, Index: Integer); overload; static; inline;
  procedure SerializeDouble(Func: TSerializeFunc; Header: Integer; const Value: Double); static; inline;
  procedure SerializeFloat(Func: TSerializeFunc; Header: Integer; const Value: Single); static; inline;
  procedure SerializeInt64(Func: TSerializeFunc; Header: Integer; const Value: Int64); static; inline;
  procedure SerializeUInt64(Func: TSerializeFunc; Header: Integer; const Value: QWord); static; inline;
  procedure SerializeInt32(Func: TSerializeFunc; Header: Integer; const Value: LongInt); static; inline;
  //procedure SerializeFixed64(Func: TSerializeFunc; Header: Integer; const Value: Fixed64); static; inline;
  //procedure SerializeFixed32(Func: TSerializeFunc; Header: Integer; const Value: Fixed32); static; inline;
  procedure SerializeBool(Func: TSerializeFunc; Header: Integer; const Value: Boolean); static; inline;
  procedure SerializeString(Func: TSerializeFunc; Header: Integer; const Value: AnsiString); overload; static; inline;
  procedure SerializeMessage(Func: TSerializeFunc; Header: Integer; const Value: TProtoMessageObject); overload; static; inline;
  procedure SerializeBytes(Func: TSerializeFunc; Header: Integer; const Value: TBytes); static; inline;
  procedure SerializeUInt32(Func: TSerializeFunc; Header: Integer; const Value: Cardinal); static; inline;
  procedure SerializeEnum(Func: TSerializeFunc; Header: Integer; const Value: Byte); overload; static; inline;
  procedure SerializeEnum(Func: TSerializeFunc; Header: Integer; const Value: Word); overload; static; inline;
  procedure SerializeEnum(Func: TSerializeFunc; Header: Integer; const Value: Cardinal); overload; static; inline;
  //procedure SerializeSFixed32(Func: TSerializeFunc; Header: Integer; const Value: SFixed32); static; inline;
  //procedure SerializeSFixed64(Func: TSerializeFunc; Header: Integer; const Value: SFixed64); static; inline;
  procedure SerializeSInt32(Func: TSerializeFunc; Header: Integer; const Value: LongInt); static; inline;
  procedure SerializeSInt64(Func: TSerializeFunc; Header: Integer; const Value: QWord); static; inline;
  class procedure IgnoreError(Id: Integer; const Msg: AnsiString); static;
  class var ErrorHandler: TErrorHandler;

public
  procedure FailedWritingData; static;
  procedure FailedReadingData; static;
end;

type
  {generic} TRepeated<TItem> = object
  public type
    TPtr = ^TRepeated<TItem>;
    PItem = ^TItem;
  private type
    PNode = ^TNode;
    TNode = record
      Next: PNode;
      Item: TItem;
    end;
  private
    FFirst, FLast: PNode;
    // function GetItem(Index: Integer): PItem;
  public
    constructor Init;
    constructor CopyFrom(Other: Pointer); overload;
    destructor Done;
    procedure Add(const Item: TItem);
    //function Add: PItem;
    //procedure Clear;
    //property Count: Integer read FCount;
    //property Items[Index: Integer]: PItem read GetItem; default;
  public
    procedure Copy(out Dst: Double; P: Pointer); overload; inline;
    procedure Copy(out Dst; P: Pointer); overload; inline;
  end;
  TRepeatedDouble = {specialize} TRepeated<Double>;
  TRepeatedSingle = {specialize} TRepeated<Single>;
  TRepeatedInt64 = {specialize} TRepeated<Int64>;
  TRepeatedQWord = {specialize} TRepeated<QWord>;
  TRepeatedLongInt = {specialize} TRepeated<LongInt>;
  TRepeatedFixed64 = TRepeatedInt64;
  TRepeatedFixed32 = TRepeatedLongInt;
  TRepeatedBoolean = {specialize} TRepeated<Boolean>; // TODO bitmask
  TRepeatedAnsiString = {specialize} TRepeated<AnsiString>;
  TRepeatedBytes = {specialize} TRepeated<TBytes>; // WTF? :)
  TRepeatedCardinal = {specialize} TRepeated<Cardinal>;
  TRepeatedSFixed32 = TRepeatedLongInt;
  TRepeatedSFixed64 = TRepeatedInt64;
{
type
  // need to declare it outside of TProtobuf
  TRepeatedDouble = TProtobuf.TRepeatedDouble;
  TRepeatedSingle = TProtobuf.TRepeatedSingle;
  TRepeatedInt64 = TProtobuf.TRepeatedInt64;
  TRepeatedQWord = TProtobuf.TRepeatedQWord;
  TRepeatedLongInt = TProtobuf.TRepeatedLongInt;
  TRepeatedFixed64 = TProtobuf.TRepeatedFixed64;
  TRepeatedFixed32 = TProtobuf.TRepeatedFixed32;
  TRepeatedBoolean = TProtobuf.TRepeatedBoolean;
  TRepeatedAnsiString = TProtobuf.TRepeatedAnsiString;
  TRepeatedTBytes = TProtobuf.TRepeatedTBytes;
  TRepeatedCardinal = TProtobuf.TRepeatedCardinal;
  TRepeatedSFixed32 = TProtobuf.TRepeatedSFixed32;
  TRepeatedSFixed64 = TProtobuf.TRepeatedSFixed64;
}

implementation

procedure TProtoMessageObject.Serialize(Func: TSerializeFunc);
begin
  ComputeSize;
  DoSerialize(Func);
end;

procedure TProtoMessageObject.Parse(Func: TParseFunc);
begin
  DoParse(Func);
end;

constructor TRepeated<TItem>.Init;
begin
end;

constructor TRepeated<TItem>.CopyFrom(Other: Pointer);
begin
end;

destructor TRepeated<TItem>.Done;
begin
end;

procedure TRepeated<TItem>.Add(const Item: TItem);
var
  Node: PNode;
begin
  New(Node);
  Node^.Next := nil;
  Node^.Item := Item;
  if FLast = nil then begin
    FFirst := Node;
    FLast := Node;
  end else begin
    FLast^.Next := Node;
    FLast := Node;
  end;
end;

procedure TRepeated<TItem>.Copy(out Dst: Double; P: Pointer);
begin
  Dst := Double(P^);
end;

procedure TRepeated<TITem>.Copy(out Dst; P: Pointer);
begin
end;

procedure TProtobuf.FailedWritingData;
begin
  ErrorHandler(2, 'TProtobuf: failed writing data');
end;

procedure TProtobuf.FailedReadingData; static;
begin
  ErrorHandler(1, 'TProtobuf: failed reading data');
end;

function TProtobuf.ParseVarint(Func: TParseFunc): LongInt;
var
  P: LongInt;
  B: Byte;
begin
  Result := 0;
  P := 0;
  while True do begin
    if Func(@B, 1) <> 1 then begin
      ErrorHandler(1, 'TProtobuf.ParseVarint: failed read data');
      Exit;
    end;
    Result := (Result {shl 7}) or ((B and 127) shl P);
    if (B and 128) = 0 then
      Exit;
    Inc(P,  7);
  end;
end;

procedure TProtobuf.ParseHeader(Func: TParseFunc; out Wire, Index: Integer);
begin
end;

procedure TProtobuf.ParseDouble(Func: TParseFunc; out Value: Double);
begin
  Func(@Value, SizeOf(Value));
end;

procedure TProtobuf.ParseFloat(Func: TParseFunc; out Value: Single);
begin
  Func(@Value, SizeOf(Value));
end;

procedure TProtobuf.ParseInt64(Func: TParseFunc; out Value: Int64);
begin
  Value := ParseVarint(Func);
end;

procedure TProtobuf.ParseUInt64(Func: TParseFunc; out Value: QWord);
begin
  Value := ParseVarint(Func);
end;

procedure TProtobuf.ParseInt32(Func: TParseFunc; out Value: LongInt);
begin
  Value := ParseVarint(Func);
end;

//procedure TProtobuf.ParseFixed64(Func: TParseFunc; out Value: Fixed64);
//procedure TProtobuf.ParseFixed32(Func: TParseFunc; out Value: Fixed32);

procedure TProtobuf.ParseBool(Func: TParseFunc; out Value: Boolean);
begin
  Value := ParseVarint(Func) <> 0;
end;

procedure TProtobuf.ParseString(Func: TParseFunc; out Value: AnsiString);
var
  I: LongInt;
  C: AnsiChar;
begin
  SetLength(Value, ParseVarint(Func));
  Func(@Value[1], Length(Value));
end;

procedure TProtobuf.ParseMessage(Func: TParseFunc; out Value: TProtoMessageObject);
begin
  // ???
end;

procedure TProtobuf.ParseBytes(Func: TParseFunc; out Value: TBytes);
begin
  SetLength(Value, ParseVarint(Func));
  Func(@Value[0], Length(Value));
end;

procedure TProtobuf.ParseUInt32(Func: TParseFunc; out Value: Cardinal);
begin
  Value := ParseVarint(Func);
end;

procedure TProtobuf.ParseEnum(Func: TParseFunc; out Value: Byte);
begin
  Value := ParseVarint(Func);
end;

procedure TProtobuf.ParseEnum(Func: TParseFunc; out Value: Word);
begin
  Value := ParseVarint(Func);
end;

procedure TProtobuf.ParseEnum(Func: TParseFunc; out Value: Cardinal);
begin
  Value := ParseVarint(Func);
end;

//procedure TProtobuf.ParseSFixed32(Func: TParseFunc; out Value: SFixed32);
//procedure TProtobuf.ParseSFixed64(Func: TParseFunc; out Value: SFixed64);

procedure TProtobuf.ParseSInt32(Func: TParseFunc; out Value: LongInt);
begin
  Value := ParseVarint(Func);
end;

procedure TProtobuf.ParseSInt64(Func: TParseFunc; out Value: QWord);
begin
  Value := ParseVarint(Func);
end;

procedure TProtobuf.ParseSkip(Func: TParseFunc; Count: Integer);
begin
  if Func(nil, Count) <> Count then
    FailedReadingData;
end;

procedure TProtobuf.ParseSkipValue(Func: TParseFunc; Wire: Integer);
begin
  case Wire of
    WIRE_VARINT: ParseVarint(Func);
    WIRE_64BIT: ParseSkip(Func, 8);
    WIRE_LENGTH_DELIMITED: ParseSkip(Func, ParseVarint(Func));
    WIRE_START_GROUP: ErrorHandler(3, 'TProtobuf: start group parsing is not supported');
    WIRE_END_GROUP: ErrorHandler(4, 'TProtobuf: end group parsing is not supported');
    WIRE_32BIT: ParseSkip(Func, 4);
  else
    ErrorHandler(5, 'TProtobuf: unknown wire type');
  end;
end;

procedure TProtobuf.SerializeVarint(Func: TSerializeFunc; Value: LongInt);
var
  B: Byte;
begin
  while Value <> 0 do begin
    B := Value and 127;
    Value := Value shr 7;
    if Value <> 0 then
      B := B or 128;
    if Func(@B, 1) <> 1 then begin
      FailedWritingData;
      Exit;
    end;
  end;
end;

procedure TProtobuf.SerializeVarint(Func: TSerializeFunc; Value: Int64);
var
  B: Byte;
begin
  while Value <> 0 do begin
    B := Value and 127;
    Value := Value shr 7;
    if Value <> 0 then
      B := B or 128;
    if Func(@B, 1) <> 1 then begin
      FailedWritingData;
      Exit;
    end;
  end;
end;

procedure TProtobuf.SerializeHeader(Func: TSerializeFunc; Wire, Index: Integer);
begin
  SerializeVarint(Func, Wire + (Index shl 3));
end;

procedure TProtobuf.SerializeDouble(Func: TSerializeFunc; Header: Integer; const Value: Double);
begin
  SerializeVarint(Func, Header);
  if Func(@Value, SizeOf(Value)) <> SizeOf(Value) then
    FailedWritingData;
end;

procedure TProtobuf.SerializeFloat(Func: TSerializeFunc; Header: Integer; const Value: Single);
begin
  SerializeVarint(Func, Header);
  if Func(@Value, SizeOf(Value)) <> SizeOf(Value) then
    FailedWritingData;
end;

procedure TProtobuf.SerializeInt64(Func: TSerializeFunc; Header: Integer; const Value: Int64);
begin
  SerializeVarint(Func, Header);
  SerializeVarint(Func, Value);
end;

procedure TProtobuf.SerializeUInt64(Func: TSerializeFunc; Header: Integer; const Value: QWord);
begin
  SerializeVarint(Func, Header);
  SerializeVarint(Func, Int64(Value));
end;

procedure TProtobuf.SerializeInt32(Func: TSerializeFunc; Header: Integer; const Value: LongInt);
begin
  SerializeVarint(Func, Header);
  SerializeVarint(Func, Value);
end;

procedure TProtobuf.SerializeBool(Func: TSerializeFunc; Header: Integer; const Value: Boolean);
begin
  SerializeVarint(Func, Header);
  SerializeVarint(Func, Ord(Value));
end;

procedure TProtobuf.SerializeString(Func: TSerializeFunc; Header: Integer; const Value: AnsiString);
begin
  SerializeVarint(Func, Header);
  SerializeVarint(Func, Length(Value));
  if Func(@Value[1], Length(Value)) <> Length(Value) then
    FailedWritingData;
end;

procedure TProtobuf.SerializeMessage(Func: TSerializeFunc; Header: Integer; const Value: TProtoMessageObject);
begin
  SerializeVarint(Func, Header);
  SerializeVarint(Func, Value.Size);
  Value.Serialize(Func);
end;

procedure TProtobuf.SerializeBytes(Func: TSerializeFunc; Header: Integer; const Value: TBytes);
begin
  SerializeVarint(Func, Header);
  SerializeVarint(Func, Length(Value));
  if Func(@Value[0], Length(Value)) <> Length(Value) then
    FailedWritingData;
end;

procedure TProtobuf.SerializeUInt32(Func: TSerializeFunc; Header: Integer; const Value: Cardinal);
begin
  SerializeVarint(Func, Header);
  SerializeVarint(Func, LongInt(Value));
end;

procedure TProtobuf.SerializeEnum(Func: TSerializeFunc; Header: Integer; const Value: Byte);
begin
  SerializeVarint(Func, Header);
  SerializeVarint(Func, LongInt(Value));
end;

procedure TProtobuf.SerializeEnum(Func: TSerializeFunc; Header: Integer; const Value: Word);
begin
  SerializeVarint(Func, Header);
  SerializeVarint(Func, LongInt(Value));
end;

procedure TProtobuf.SerializeEnum(Func: TSerializeFunc; Header: Integer; const Value: Cardinal);
begin
  SerializeVarint(Func, Header);
  SerializeVarint(Func, LongInt(Value));
end;

procedure TProtobuf.SerializeSInt32(Func: TSerializeFunc; Header: Integer; const Value: LongInt);
begin
  SerializeVarint(Func, Header);
  SerializeVarint(Func, Value);
end;

procedure TProtobuf.SerializeSInt64(Func: TSerializeFunc; Header: Integer; const Value: QWord);
begin
  SerializeVarint(Func, Header);
  SerializeVarint(Func, Int64(Value));
end;

class procedure TProtobuf.IgnoreError(Id: Integer; const Msg: AnsiString);
begin
end;

initialization
  TProtobuf.ErrorHandler := @TProtobuf.IgnoreError;
end.
