unit uROBinaryHelpers;

{----------------------------------------------------------------------------}
{ RemObjects SDK Library - Core Library                                      }
{                                                                            }
{ compiler: Delphi 5 and up, Kylix 2 and up                                  }
{ platform: Win32, Linux                                                     }
{                                                                            }
{ (c)opyright RemObjects Software. all rights reserved.                      }
{                                                                            }
{ Using this code requires a valid license of the RemObjects SDK             }
{ which can be obtained at http://www.remobjects.com.                        }
{----------------------------------------------------------------------------}

{$I RemObjects.inc}

interface

{ToDo: -cRO3 clean up this mess, rename the methods appropriately and group
             them depending on what they do (ie handle complex variants; do
             conversions of *plain* binaries, etc. }

uses
  Classes, {$IFDEF FPC}Variants, {$ELSE}{$IFDEF VER140UP}Variants,{$ENDIF}{$ENDIF}
  uROTypes, uROClasses, FMTBcd;

type
  EROBinaryConversionException = class(EROException);
{$IFDEF FPC}OleVariant = Variant; {$ENDIF}

function BinaryFromVariant(const iVariant:OleVariant):Binary;
function VariantFromBinary(const iBinary:TStream):OleVariant;

procedure WriteVariantBinaryToBinary(const iVariant:OleVariant; ioBinary:TStream);
procedure WriteVariantArrayToBinary(const iVariant:OleVariant; ioBinary:TStream);

function VariantArrayFromBinary(const iBinary:TStream; iType:word):OleVariant;
function VariantBinaryFromBinary(const iBinary:TStream):OleVariant;

procedure WriteVariantToBinary(const iVariant:OleVariant; ioBinary:TStream);
function ReadVariantFromBinary(const iBinary:TStream):OleVariant;

function VariantBinaryFromRawBinary(const iBinary:TStream):OleVariant;
procedure VariantBinaryToRawBinary(const iVariant:OleVariant; ioBinary:TStream);
function VariantBinaryToString(const iVariant:OleVariant):string;

function Stream_ReadStringWithLength(iStream:TStream; iMaxLength:integer=-1): string;
procedure Stream_WriteStringWithLength(iStream:TStream; const iString: string);

{$IFDEF DEBUG_REMOBJECTS_VARIANTS}
function TestVariant(iVariant:OleVariant):OleVariant;
{$ENDIF DEBUG_REMOBJECTS_VARIANTS}


type
  PDecimal = ^TDecimal;
  TDecimal = array[0..3] of Cardinal;

function BCDToDecimal(const aBcd: TBcd): TDecimal;
function DecimalToBCD(const aDecimal: TDecimal): TBcd;
function DecimalToString(const aDecimal: TDecimal; aDot: Char): string;
function StringToDecimal(const aString: string; aDot: Char): TDecimal;
function DecimalToVariant(const aDecimal: TDecimal): Variant;
function VariantToDecimal(const aVariant: Variant): TDecimal;
function VariantToBCD(const aVariant: Variant): TBCD;
function BCDToVariant(const aBCD: TBCD; const StoreAsDecimal: Boolean = False): Variant;
{ ToDo: extend this to handle all common Variant types, and use it for
        marshaling OwnerData, instead of string. }

function VarByteArrayToDecimal(const aVariant: Variant; var aDecimal: TDecimal): Boolean;

implementation

uses {$IFDEF DEBUG_REMOBJECTS_VARIANTS}eDebugServer,{$ENDIF}
     SysUtils, uRORes;

procedure WriteVariantToBinary(const iVariant:OleVariant; ioBinary:TStream);
var lType:integer;
    lIntegerValue:integer;
    {$IFNDEF DELPHI5}
    lShortIntValue:shortint;
    lSmallIntValue: smallint;
    lInt64Value:Int64;
    {$ENDIF DELPHI5}
    lByteValue:byte;
    lDoubleValue:double;
    lSingleValue:single;
    lCurrencyValue:currency;
    lStringValue:string;
begin
  lType := VarType(iVariant);

  {$IFDEF DEBUG_REMOBJECTS_VARIANTS}
  DebugServer.Write('BinaryFromVariant type=%d',[lType]);
  {$ENDIF DEBUG_REMOBJECTS_VARIANTS}

  { Array types }
  if (lType and $2000) = $2000 then begin

    case lType of
      $2011:WriteVariantBinaryToBinary(iVariant,ioBinary); {8209; handle Array of Byte special. for now. }
      else WriteVariantArrayToBinary(iVariant,ioBinary);
    end;

  end
  { Plain Types }
  else begin

    case lType of
      varEmpty,varNull,varError:begin { 0, 1, A }
          ioBinary.Write(lType,sizeof(integer));
        end;
      {$IFNDEF DELPHI5}
      varShortInt:begin { 2, 10, 12 }
        lShortIntValue := iVariant;
        ioBinary.Write(lType,sizeof(integer));
        ioBinary.Write(lShortIntValue,sizeof(shortint));
      end;
      varSmallInt,varWord : begin
        lSmallIntValue := iVariant;
        ioBinary.Write(lType,sizeof(integer));
        ioBinary.Write(lSmallIntValue,sizeof(lSmallIntValue));
      end;
      {$ENDIF DELPHI5}
      {$IFNDEF DELPHI5}varLongWord,{$ENDIF DELPHI5}
      varInteger:begin { 3, 13 }
          lIntegerValue := iVariant;
          ioBinary.Write(lType,sizeof(integer));
          ioBinary.Write(lIntegerValue,sizeof(integer));
        end;
      varSingle:begin { 4 }
          lSingleValue := iVariant;
          ioBinary.Write(lType,sizeof(integer));
          ioBinary.Write(lSingleValue,sizeof(single));
        end;
      varDouble, varDate:begin { 5, 7 }
          lDoubleValue := iVariant;
          ioBinary.Write(lType,sizeof(integer));
          ioBinary.Write(lDoubleValue,sizeof(double));
        end;
      varCurrency:begin { 6 }
          lCurrencyValue := iVariant;
          ioBinary.Write(lType,sizeof(integer));
          ioBinary.Write(lCurrencyValue,sizeof(currency));
        end;
      varDispatch:begin { 9 }
          raise EROBinaryConversionException.CreateFmt(err_IDispatchMarshalingNotSupported,[VarType(iVariant)]);
        end;
      varBoolean:begin { B }
          if iVariant then lByteValue := 1 else lByteValue := 0;
          ioBinary.Write(lType,sizeof(integer));
          ioBinary.Write(lByteValue,sizeof(byte));
        end;
      varByte:begin { 11 }
          lByteValue := iVariant;
          ioBinary.Write(lType,sizeof(integer));
          ioBinary.Write(lByteValue,sizeof(byte));
        end;
      {$IFNDEF DELPHI5}
      varInt64:begin { 14 }
          lInt64Value := iVariant;
          ioBinary.Write(lType,sizeof(integer));
          ioBinary.Write(lInt64Value,sizeof(Int64));
        end;
      {$ENDIF DELPHI5}
      varOleStr:
        begin
          lStringValue := UTF8Encode(iVariant);
          lIntegerValue := Length(lStringValue);
          ioBinary.Write(lType,sizeof(integer));
          ioBinary.Write(lIntegerValue,sizeof(integer));
          ioBinary.Write(lStringValue[1],lIntegerValue);
        end;
      varString:begin { 8, 100 }
          lStringValue := iVariant;
          lIntegerValue := Length(lStringValue);
          ioBinary.Write(lType,sizeof(integer));
          ioBinary.Write(lIntegerValue,sizeof(integer));
          ioBinary.Write(lStringValue[1],lIntegerValue);
        end;
      else raise EROBinaryConversionException.CreateFmt(err_UnsupportedVariantType, [VarType(iVariant)]);
    end;    { case }

  end;
end;

function BinaryFromVariant(const iVariant:OleVariant):Binary;
begin
  result := Binary.Create();
  WriteVariantToBinary(iVariant,result);
  {$IFDEF DEBUG_REMOBJECTS_VARIANTS}
  DebugServer.WriteHexDump('Written Binary',result);
  {$ENDIF DEBUG_REMOBJECTS_VARIANTS}
  result.Seek(0,soFromBeginning)
end;

function StringFromBinary(const iBinary:TStream):string;
var lSize:integer;
begin
  iBinary.Read(lSize,sizeof(integer));
  SetLength(Result,lSize);
  iBinary.read(Result[1],lSize);
end;

function ReadVariantFromBinary(const iBinary:TStream):OleVariant;
var lType:integer;
    lIntegerValue:integer;
    {$IFNDEF DELPHI5}
    lShortInt:shortint;
    lSmallIntValue: smallint;
    lInt64Value:Int64;
    {$ENDIF DELPHI5}
    lByteValue:byte;
    lDoubleValue:double;
    lSingleValue:single;
    lCurrencyValue:currency;
    lString: string;
begin
  iBinary.Read(lType,sizeof(integer));

  {$IFDEF DEBUG_REMOBJECTS_VARIANTS}
  DebugServer.Write('VariantFromBinary type=%d',[lType]);
  {$ENDIF DEBUG_REMOBJECTS_VARIANTS}

  { Array types }
  if (lType and $2000) = $2000 then begin

    case lType of
      $2011:result := VariantBinaryFromBinary(iBinary);
      else result := VariantArrayFromBinary(iBinary,(lType and $fff));
    end;

  end
  { Plain Types }
  else begin

    case lType of
      varEmpty:result := Unassigned;
      varNull:result := Null;
      varError:result := EmptyParam;
      {$IFNDEF DELPHI5}
      varShortInt:begin
          iBinary.Read(lShortInt,sizeof(shortint));
          result := lShortInt;
        end;
      varSmallInt,varWord : begin
        iBinary.Read(lSmallIntValue,sizeof(lSmallIntValue));
        result := lSmallIntValue;
      end;
      {$ENDIF DELPHI5}
      {$IFNDEF DELPHI5}
      varLongWord,
      {$ENDIF DELPHI5}
      varInteger:begin
          iBinary.Read(lIntegerValue,sizeof(integer));
          result := lIntegerValue;
        end;
      varSingle:begin
          iBinary.Read(lSingleValue,sizeof(single));
          result := lSingleValue;
        end;
      varDouble:begin
          iBinary.Read(lDoubleValue,sizeof(double));
          result := lDoubleValue;
        end;
      varCurrency:begin
          iBinary.Read(lCurrencyValue,sizeof(currency));
          result := lcurrencyValue;
        end;
      varDate:begin
          iBinary.Read(lDoubleValue,sizeof(double));
          result := TDateTime(lDoubleValue);
        end;
      varBoolean:begin
          iBinary.Read(lByteValue,sizeof(byte));
          result := (lByteValue <> 0);
        end;
      varByte:begin
          iBinary.Read(lByteValue,sizeof(byte));
          result := lByteValue;
        end;
      {$IFNDEF DELPHI5}
      varInt64:begin
          iBinary.Read(lInt64Value,sizeof(Int64));
          result := lInt64Value;
        end;
      {$ENDIF DELPHI5}
      varOleStr:
        begin
          iBinary.Read(lIntegerValue,sizeof(integer));
          SetLength(lString, lIntegerValue);
          iBinary.Read(lString[1], lIntegerValue);
          Result := UTF8Decode(lString);
        end;
      varString:Result := StringFromBinary(iBinary);
      else raise EROBinaryConversionException.CreateFmt(err_UnsupportedVariantType, [lType]);
    end;    { case }
  end;
end;

function VariantFromBinary(const iBinary:TStream):OleVariant;
begin
  if iBinary.Size < 4 then raise EROBinaryConversionException.Create(err_InvalidBinaryFormat);

  {$IFDEF DEBUG_REMOBJECTS_VARIANTS}
  DebugServer.WriteHexDump('Read Binary',iBInary);
  {$ENDIF DEBUG_REMOBJECTS_VARIANTS}

  iBinary.Seek(0,soFromBeginning);
  result := ReadVariantFromBinary(iBinary);
end;

procedure CheckVariant(const iVariant:OleVariant);
begin
  // Introduced by AleF to address part of this check mess
  if not VarIsArray(iVariant)
    then raise EROBinaryConversionException.CreateFmt(err_VariantIsNotArray,[VarType(iVariant)]);

  if VarArrayDimCount(iVariant) <> 1
    then raise EROBinaryConversionException.CreateFmt(err_InvalidVarArrayDimCount, [VarArrayDimCount(iVariant)]);
end;

procedure WriteVariantBinaryToBinary(const iVariant:OleVariant; ioBinary:TStream);
var //l:longword;
    lType,lSize:integer;
    p:pointer;
begin
  CheckVariant(iVariant);

  lSize := VarArrayHighBound(iVariant,1)-VarArrayLowBound(iVariant,1)+1;

  p := VarArrayLock(iVariant);
  try
    lType := VarType(iVariant);
    {$IFDEF DEBUG_REMOBJECTS_VARIANTS}
    DebugServer.Write('BinaryFromVariantBinary type=%d',[lType]);
    {$ENDIF DEBUG_REMOBJECTS_VARIANTS}
    ioBinary.Write(lType,sizeof(integer));
    ioBinary.Write(lSize,sizeof(integer));
    ioBinary.Write(p^,lSize);
  finally
    VarArrayUnlock(iVariant);
  end;

end;

procedure WriteVariantArrayToBinary(const iVariant:OleVariant; ioBinary:TStream);
var lLowBound,lHighBound:integer;
    i:Integer;
    lType:integer;
begin
  CheckVariant(iVariant);

  lType := VarType(iVariant);
  lLowBound := VarArrayLowBound(iVariant,1);
  lHighBound := VarArrayHighBound(iVariant,1);
  //l := VarArrayHighBound(iVariant,1)-VarArrayLowBound(iVariant,1)+1;

  {$IFDEF DEBUG_REMOBJECTS_VARIANTS}
  DebugServer.Write('WriteVariantArrayToBinary type=%d, bounds=%d..%d',[lType,lLowBound,lHighBound]);
  {$ENDIF DEBUG_REMOBJECTS_VARIANTS}

  ioBinary.Write(lType,sizeof(integer));
  ioBinary.Write(lLowBound,sizeof(integer));
  ioBinary.Write(lHighBound,sizeof(integer));

  for i := lLowBound to lHighBound do begin
    WriteVariantToBinary(iVariant[i],ioBinary);
  end;

end;

function VariantBinaryFromBinary(const iBinary:TStream):OleVariant;
var p:pointer;
    lSize:integer;
begin
  iBinary.Read(lSize,sizeof(integer));
  result := VarArrayCreate([0,lSize-1],varByte);
  p := VarArrayLock(result);
  try
    iBinary.Read(p^,lSize);
  finally
    VarArrayUnlock(result);
  end;
end;



function VariantArrayFromBinary(const iBinary:TStream; iType:word):OleVariant;
var lLowBound,lHighBound:integer;
    i:Integer;
begin
  iType := (iType and $fff);

  iBinary.Read(lLowBound,sizeof(integer));
  iBinary.Read(lHighBound,sizeof(integer));

  result := VarArrayCreate([lLowBound,lHighBound],iType);

  for i := lLowBound to lHighBound do begin
    result[i] := ReadVariantFromBinary(iBinary);
  end;

end;

{$IFDEF DEBUG_REMOBJECTS_VARIANTS}
function TestVariant(iVariant:OleVariant):OleVariant;
var
  lBinary:Binary;
begin
  DebugServer.EnterMethod('Original varType '+IntToStr(VarType(iVariant)));
  lBinary := BinaryFromVariant(iVariant);
  try
    result := VariantFromBinary(lBinary);
    DebugServer.ExitMethod('Result  varType '+IntToStr(VarType(result)));
  finally
    FreeAndNil(lBinary);
  end;
end;
{$ENDIF DEBUG_REMOBJECTS_VARIANTS}


{-----------------------------------------------------------------------------}
{ Conversion fromto Binary "Array of Bytes" Variants to other data types
{ containing *just* the binary data, no additional type info.
{-----------------------------------------------------------------------------}

{ Description:
    Will read the *remainder* of the iBinary stream into a new
    binary variant (aka array of bytes). }

function VariantBinaryFromRawBinary(const iBinary:TStream):OleVariant;
var p:pointer;
    lSize:integer;
begin
  lSize := iBinary.Size-iBinary.Position;

  result := VarArrayCreate([0,lSize-1],varByte);
  p := VarArrayLock(result);
  try
    iBinary.Read(p^,lSize);
  finally
    VarArrayUnlock(result);
  end;
end;

{ Description:
    Will write the data from the binary variant (aka array of bytes) to the
    current position of the iBinary stream. }
procedure VariantBinaryToRawBinary(const iVariant:OleVariant; ioBinary:TStream);
var
  lSize:integer;
  p:pointer;
begin
  if (VarType(iVariant)=varEmpty) then Exit;

  CheckVariant(iVariant);

  lSize := VarArrayHighBound(iVariant,1)-VarArrayLowBound(iVariant,1)+1;

  p := VarArrayLock(iVariant);
  try
    ioBinary.Write(p^,lSize);
  finally
    VarArrayUnlock(iVariant);
  end;

end;

{ Description:
    Will return the data from the binary variant (aka array of bytes) as a
    binary AnsiString }
function VariantBinaryToString(const iVariant:OleVariant):string;
var
  lSize:integer;
  p:pointer;
begin
  if (VarType(iVariant)=varEmpty) then Exit;
  if not VarIsArray(iVariant) then begin
    Result:= VarToStr(iVariant);
    Exit;
  end;

  CheckVariant(iVariant);

  lSize := VarArrayHighBound(iVariant,1)-VarArrayLowBound(iVariant,1)+1;

  p := VarArrayLock(iVariant);
  try
    SetLength(result,lSize);
    if lSize > 0 then
      Move(p^,result[1],lSize);
  finally
    VarArrayUnlock(iVariant);
  end;

end;

function Stream_ReadStringWithLength(iStream:TStream; iMaxLength:integer=-1): string;
var lLength:integer;
    lBytesRead:Integer;
begin
  lBytesRead := iStream.Read(lLength, sizeof(lLength));
  if lBytesRead <> sizeof(lLength) then RaiseError(err_UnexpectedEndOfStream,[]);

  if (iMaxLength > -1) and (lLength > iMaxLength) then
    RaiseError(err_InvalidStringLength,[lLength]);

  SetLength(result, lLength);
  if (lLength > 0) then
    iStream.Read(result[1], lLength);
  //ToDo: find a save and FAST way to do this in .NET
end;

procedure Stream_WriteStringWithLength(iStream:TStream; const iString: string);
var lLength:integer;
begin
  lLength := Length(iString);
  iStream.Write(lLength, SizeOf(lLength));
  if (lLength > 0) then
    iStream.Write(iString[1], lLength);
  //ToDo: find a save and FAST way to do this in .NET
end;

var
  numbers: array[0..9] of char = '0123456789';

function DecimalToString(const aDecimal: TDecimal; aDot: Char): string;
var
  modres: Integer;
  d: Int64;
  pos: Integer;
  scale: Integer;
  sign: Boolean;
  aDec: TDecimal;
  aResult: array[0..31] of Char;
begin
  aDec := aDecimal;
  sign := (aDecimal[3] and $80000000) <> 0;
  scale := (aDecimal[3] and $FF0000) shr 16;
  pos := 31;
  while (aDec[0] <> 0) or (aDec[1] <> 0) or (aDec[2] <> 0) or (31 - pos < scale) do begin
    modres := 0;
    d := Int64(Int64(ModRes) shl 32) or aDec[2];
    ModRes := d mod 10;
    aDec[2] := d div 10;
    d := Int64(Int64(ModRes) shl 32) or aDec[1];
    ModRes := d mod 10;
    aDec[1] := d div 10;
    d := Int64(Int64(ModRes) shl 32) or aDec[0];
    ModRes := d mod 10;
    aDec[0] := d div 10;

    aResult[pos] := numbers[Modres];
    Dec(pos);
    if 31 - pos = scale then begin
      aresult[pos] := aDot;
      dec(pos);
      if (aDec[0] = 0) and (aDec[1] = 0) and (aDec[2] = 0) then begin
        aresult[pos] := '0';
        dec(pos);
      end;
    end;
  end;
  if pos = 31 then begin result := '0'; exit; end;
  if sign then begin
    aResult[pos] := '-';
    dec(pos);
  end;
  SetString(Result, pchar(@aResult[pos+1]), 31-Pos);
end;

function StringToDecimal(const aString: string; aDot: Char): TDecimal;
var
  scalepos, pos, i: Integer;
  mulres: Integer;
  d: Int64;
  aRes: TDecimal;
begin
  Fillchar(aRes, sizeof(aRes), 0);
  pos := 0;
  scalepos := -1;
  for i := 0 to Length(aString) do begin
    mulres := 0;
    case aString[i] of
      '0': ; // already set
      '1': mulres := 1;
      '2': mulres := 2;
      '3': mulres := 3;
      '4': mulres := 4;
      '5': mulres := 5;
      '6': mulres := 6;
      '7': mulres := 7;
      '8': mulres := 8;
      '9': mulres := 9;
      else begin
        if aString[i] = '-' then begin
          aRes[3] := aRes[3] or $80000000;
          continue;
        end else if aString[i] = aDot then begin
          if scalepos = -1 then
          scalepos := pos;
          continue;
        end else
          continue; // ignore invalid chars for now
      end;
    end;
    d := Int64(aRes[0]) * 10 + mulres;
    mulres := d shr 32;
    aRes[0] := d;
    d := Int64(aRes[1]) * 10 + mulres;
    mulres := d shr 32;
    aRes[1] := d;
    aRes[2] := Int64(aRes[2]) * 10 + mulres;
    Inc(pos);
  end;
  if scalepos <> -1 then begin
    pos:= pos - scalepos;
    aRes[3] := aRes[3] or Cardinal(Pos shl 16);
  end;
  Result := aRes;
end;


function BCDToDecimal(const aBcd: TBcd): TDecimal;
begin
  Result := StringToDecimal(BcdToStr(aBcd), DecimalSeparator);
end;

function DecimalToBCD(const aDecimal: TDecimal): TBcd;
begin
  Result := StrToBcd(DecimalToString(aDecimal, DecimalSeparator));
end;

function DecimalToVarByteArray(const aDecimal: TDecimal): Variant;
var
  p: Pointer;
begin
  Result := VarArrayCreate([0,SizeOf(TDecimal)-1],varByte);
  p := VarArrayLock(Result);
  try
    move(PDecimal(@aDecimal)^, p^ ,SizeOf(TDecimal));
  finally
    VarArrayUnlock(Result);
  end;
end;

function VarByteArrayToDecimal(const aVariant: Variant; var aDecimal: TDecimal): Boolean;
var
  p: Pointer;
begin
  Result:= False;
  if (VarType(aVariant) = varByte or varArray) and
     (VarArrayDimCount(aVariant) = 1) and
     (VarArrayHighBound(aVariant,1)-VarArrayLowBound(aVariant,1)+1 = SizeOf(TDecimal)) then begin
    p := VarArrayLock(aVariant);
    try
      move(p^, PDecimal(@aDecimal)^, SizeOf(TDecimal));
    finally
      VarArrayUnlock(aVariant);
    end;
    Result:=True;
  end;
end;

function DecimalToVariant(const aDecimal: TDecimal): Variant;
begin
  Result := DecimalToVarByteArray(aDecimal);
end;

function VariantToDecimal(const aVariant: Variant): TDecimal;
var
  s: string;
begin
  if VarIsNull(aVariant) then
    FillChar(PDecimal(@result)^,SizeOf(Result),0)
  else if not VarByteArrayToDecimal(aVariant,Result) then begin
    if VarIsFMTBcd(aVariant) then
      s:=BcdToStr(VarToBcd(aVariant))
    else
      s:=VarToStr(aVariant);
    Result:=StringToDecimal(s, DecimalSeparator);
  end;
end;

function VariantToBCD(const aVariant: Variant): TBCD;
var
  aDecimal: TDecimal;
begin
  if VarIsNull(aVariant) then
    Result := NullBcd
  else if VarByteArrayToDecimal(aVariant,aDecimal) then
    Result:=DecimalToBCD(aDecimal)
  else begin
    if VarIsFMTBcd(aVariant) then
      Result := VarToBcd(aVariant)
    else
      Result:= StrToBcd(VarToStr(aVariant));
  end;
end;

function BCDToVariant(const aBCD: TBCD; const StoreAsDecimal: Boolean): Variant;
begin
  if StoreAsDecimal then
    Result := DecimalToVarByteArray(BCDToDecimal(aBCD))
  else
    Result := VarFMTBcdCreate(aBCD);
end;

end.