david
2824855ea7
- Recompilación en Delphi10 de todos los paquetes de RO para generar las DCU's en Lib\D10 - Recompilación en Delphi10 de todos los paquetes de DA para generar las DCU's en Lib\D10 git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@9 b6239004-a887-0f4b-9937-50029ccdca16
711 lines
21 KiB
ObjectPascal
711 lines
21 KiB
ObjectPascal
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.
|