fmtbcd.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

{ *************************************************************************** }
{                                                                             }
{ Kylix and Delphi Cross-Platform Visual Component Library                    }
{                                                                             }
{ Copyright (c) 1995, 2001 Borland Software Corporation                       }
{                                                                             }
{ *************************************************************************** }


unit FMTBcd;

interface

uses SysUtils, Variants;

const

  MaxStringDigits = 100;
  _NoDecimal = -255;
  _DefaultDecimals = 10;

  { From DB.pas }
  { Max supported by Midas }
  MaxFMTBcdFractionSize = 64;
  { Max supported by Midas }
  MaxFMTBcdDigits =   32;
  DefaultFMTBcdScale = 6;
  MaxBcdPrecision =   18;
  MaxBcdScale     =   4;

type

  PBcd = ^TBcd;
  TBcd  = packed record
    Precision: Byte;                        { 1..64 }
    SignSpecialPlaces: Byte;                { Sign:1, Special:1, Places:6 }
    Fraction: packed array [0..31] of Byte; { BCD Nibbles, 00..99 per Byte, high Nibble 1st }
  end;

{ Exception classes }

  EBcdException = class(Exception);
  EBcdOverflowException = class(EBcdException);

{ Utility functions for TBcd access }

function BcdPrecision(const Bcd: TBcd): Word;
function BcdScale(const Bcd: TBcd): Word;
function IsBcdNegative(const Bcd: TBcd): Boolean;

{ Bcd Arithmetic}

procedure BcdAdd(const bcdIn1, bcdIn2: TBcd; var bcdOut: TBcd);
procedure BcdSubtract(const bcdIn1, bcdIn2: TBcd; var bcdOut: TBcd);
{ Returns True if successful, False if Int Digits needed to be truncated }
function NormalizeBcd(const InBcd: TBcd; var OutBcd: TBcd; const Prec, Scale: Word): Boolean;

procedure BcdMultiply(const bcdIn1, bcdIn2: TBcd; var bcdOut: TBcd); overload;
procedure BcdMultiply(const bcdIn: TBcd; const DoubleIn: Double; var bcdOut: TBcd); overload;
procedure BcdMultiply(const bcdIn: TBcd; const StringIn: string; var bcdOut: TBcd); overload;
procedure BcdMultiply(StringIn1, StringIn2: string; var bcdOut: TBcd); overload;
procedure BcdDivide(Dividend, Divisor: string; var bcdOut: TBcd); overload;
procedure BcdDivide(const Dividend, Divisor: TBcd; var bcdOut: TBcd); overload;
procedure BcdDivide(const Dividend: TBcd; const Divisor: Double; var bcdOut: TBcd); overload;
procedure BcdDivide(const Dividend: TBcd; const Divisor: string; var bcdOut: TBcd); overload;

{ TBcd variant creation utils }
procedure VarFMTBcdCreate(var ADest: Variant; const ABcd: TBcd); overload;
function VarFMTBcdCreate: Variant; overload;
function VarFMTBcdCreate(const AValue: string; Precision, Scale: Word): Variant; overload;
function VarFMTBcdCreate(const AValue: Double; Precision: Word = 18; Scale: Word = 4): Variant; overload;
function VarFMTBcdCreate(const ABcd: TBcd): Variant; overload;
function VarIsFMTBcd(const AValue: Variant): Boolean; overload;
function VarFMTBcd: TVarType;

{ Convert String/Double/Integer to BCD struct }
function StrToBcd(const AValue: string): TBcd; 
function TryStrToBcd(const AValue: string; var Bcd: TBcd): Boolean;
function DoubleToBcd(const AValue: Double): TBcd; overload;
procedure DoubleToBcd(const AValue: Double; var bcd: TBcd); overload;
function IntegerToBcd(const AValue: Integer): TBcd;
function VarToBcd(const AValue: Variant): TBcd;

{ From DB.pas }
function CurrToBCD(const Curr: Currency; var BCD: TBcd; Precision: Integer = 32;
  Decimals: Integer = 4): Boolean;

{ Convert Bcd struct to string/Double/Integer }
function BcdToStr(const Bcd: TBcd): string; overload;
function BcdToDouble(const Bcd: TBcd): Double;
function BcdToInteger(const Bcd: TBcd; Truncate: Boolean = False): Integer;

{ From DB.pas }
function BCDToCurr(const BCD: TBcd; var Curr: Currency): Boolean;
{ Formatting Bcd as string }
function BcdToStrF(const Bcd: TBcd; Format: TFloatFormat; const Precision, Digits: Integer): string;
function FormatBcd(const Format: string; Bcd: TBcd): string;
function BcdCompare(const bcd1, bcd2: TBcd): Integer;

const

  NullBcd: TBcd = (Precision: 0; SignSpecialPlaces: 0; Fraction: (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0));

implementation

uses VarUtils, SysConst, DBConsts, TypInfo, Math, Classes;

type

{ TFMTBcdVariantType }

  TFMTBcdVariantType = class(TPublishableVariantType)
  protected
    function GetInstance(const V: TVarData): TObject; override;
  public
    procedure Clear(var V: TVarData); override;
    procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;
    procedure Cast(var Dest: TVarData; const Source: TVarData); override;
    procedure CastTo(var Dest: TVarData; const Source: TVarData; const AVarType: TVarType); override;
    procedure BinaryOp(var Left: TVarData; const Right: TVarData; const Operator: TVarOp); override;
    procedure Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult); override;
  end;

var

{ FMTBcd that the complex variant points to }

  FMTBcdVariantType: TFMTBcdVariantType = nil;

type

{ TFMTBcdData }

  TFMTBcdData = class(TPersistent)
  private
    FBcd: TBcd;
    function GetAsCurrency: Currency;
    function GetAsDouble: Double;
    function GetAsInteger: Integer;
    function GetAsString: string;
    function GetAsSmallInt: SmallInt;
    procedure SetAsCurrency(const Value: Currency);
    procedure SetAsDouble(const Value: Double);
    procedure SetAsInteger(const Value: Integer);
    procedure SetAsSmallInt(const Value: SmallInt);
    procedure SetAsString(const Value: string);
  public
    constructor Create(const AValue: Integer); overload;
    constructor Create(const AValue: Double; Precision, Scale: Word); overload;
    constructor Create(const AValue: Currency); overload;
    constructor Create(const AText: string; Precision, Scale: Word); overload;
    constructor Create(const ABcd: TBcd); overload;
    constructor Create(const ASource: TFMTBcdData); overload;

    property Bcd: TBcd read FBcd write FBcd;

    function Compare(const Value: TFMTBcdData): TVarCompareResult;

    procedure DoAdd(const Value: TBcd); overload;
    procedure DoAdd(const AFMTBcd: TFMTBcdData); overload;
    procedure DoSubtract(const Value: TBcd); overload;
    procedure DoSubtract(const AFMTBcd: TFMTBcdData); overload;
    procedure DoMultiply(const ABcdData: TFMTBcdData); overload;
    procedure DoDivide(const ABcdData: TFMTBcdData); overload;
  published
    { Conversion }
    property AsCurrency: Currency read GetAsCurrency write SetAsCurrency;
    property AsDouble: Double read GetAsDouble write SetAsDouble;
    property AsInteger: Integer read GetAsInteger write SetAsInteger;
    property AsSmallInt: SmallInt read GetAsSmallInt write SetAsSmallInt;
    property AsString: string read GetAsString write SetAsString;
  end;

{ Helper record that helps crack open TFMTBcdObject }

  TFMTBcdVarData = packed record
    VType: TVarType;
    Reserved1, Reserved2, Reserved3: Word;
    VBcd: TFMTBcdData;
    Reserved4: LongWord;
  end;

procedure BcdErrorFmt(const Message, BcdAsString: string);
begin
  raise EBcdException.Create(Format(Message, [BcdAsString]));
end;

procedure BcdError(const Message: string);
begin
  raise EBcdException.Create(Message);
end;

procedure OverflowError(const Message: string);
begin
  raise EBcdOverflowException.Create(Message);
end;

{ TFMTBcdData }

procedure TFMTBcdData.DoAdd(const Value: TBcd);
var
  NewBcd: TBcd;
begin
  BcdAdd(Self.Bcd, Value, NewBcd);
  Self.Bcd := NewBcd;
end;

procedure TFMTBcdData.DoAdd(const AFMTBcd: TFMTBcdData);
begin
  DoAdd(AFMTBcd.Bcd);
end;

procedure TFMTBcdData.DoSubtract(const Value: TBcd);
var
  NewBcd: TBcd;
begin
  BcdSubtract(Self.Bcd, Value, NewBcd);
  Self.Bcd := NewBcd;
end;

procedure TFMTBcdData.DoSubtract(const AFMTBcd: TFMTBcdData);
begin
  DoSubtract(AFMTBcd.Bcd);
end;

procedure TFMTBcdData.DoMultiply(const ABcdData: TFMTBcdData);
var
  ABcd: TBcd;
begin
  BcdMultiply(Self.Bcd, ABcdData.Bcd, ABcd);
  Self.Bcd := ABcd;
end;

procedure TFMTBcdData.DoDivide(const ABcdData: TFMTBcdData);
var
  ABcd: TBcd;
begin
  BcdDivide(Self.Bcd, ABcdData.Bcd, ABcd);
  Self.Bcd := ABcd;
end;

function TFMTBcdData.Compare(const Value: TFMTBcdData): TVarCompareResult;
begin
  Result := TVarCompareResult(BcdCompare(Self.FBcd, Value.FBcd)+1);
end;

function TFMTBcdData.GetAsString: string;
begin
  Result := BcdToStr(Self.FBcd);
end;

function TFMTBcdData.GetAsDouble: Double;
begin
  Result := StrToFloat(BcdToStr(Self.FBcd));
end;

function TFMTBcdData.GetAsInteger: Integer;
begin
  Result := StrToInt(BcdToStr(Self.FBcd));
end;

function TFMTBcdData.GetAsSmallInt: SmallInt;
begin
  Result := SmallInt(GetAsInteger);
end;

function TFMTBcdData.GetAsCurrency: Currency;
begin
  BCDToCurr(Self.FBcd, Result);
end;

procedure TFMTBcdData.SetAsString(const Value: string);
begin
  FBcd := StrToBcd(Value);
end;

procedure TFMTBcdData.SetAsDouble(const Value: Double);
begin
  FBcd := StrToBcd(FloatToStr(Value));
end;

procedure TFMTBcdData.SetAsInteger(const Value: Integer);
begin
  FBcd := StrToBcd(IntToStr(Value));
end;

procedure TFMTBcdData.SetAsSmallInt(const Value: SmallInt);
begin
  SetAsInteger(Integer(Value));
end;

procedure TFMTBcdData.SetAsCurrency(const Value: Currency);
begin
  CurrToBcd(Value, FBcd);
end;

constructor TFMTBcdData.Create(const ABcd: TBcd);
begin
  inherited Create;
  Move(ABcd, FBcd, SizeOf(TBcd));
end;

constructor TFMTBcdData.Create(const AValue: Integer);
begin
  Create(IntegerToBcd(AValue));
end;

constructor TFMTBcdData.Create(const AValue: Double; Precision, Scale: Word);
var
  ABcd, OutBcd: TBcd;
begin
  ABcd := StrToBcd(FloatToStr(AValue));
  if not NormalizeBcd(ABcd, OutBcd, Precision, Scale) then
    OverflowError(SBcdOverflow);
  Create(OutBcd);
end;

constructor TFMTBcdData.Create(const AValue: Currency);
var
  OutBcd: TBcd;
begin
  CurrToBcd(AValue, OutBcd);
  Create(OutBcd);
end;

constructor TFMTBcdData.Create(const AText: string; Precision, Scale: Word);
var
  ABcd, OutBcd: TBcd;
begin
  ABcd := StrToBcd(AText);
  if not NormalizeBcd(ABcd,OutBcd,Precision,Scale) then
    OverflowError(SBcdOverflow);
  Create(OutBcd);
end;

constructor TFMTBcdData.Create(const ASource: TFMTBcdData);
begin
  Create(aSource.Bcd);
end;

{ TFMTBcdVariantType }

procedure TFMTBcdVariantType.Clear(var V: TVarData);
begin
  V.VType := varEmpty;
  FreeAndNil(TFMTBcdVarData(V).VBcd);
end;

procedure TFMTBcdVariantType.Cast(var Dest: TVarData;
  const Source: TVarData);
var
  LSource, LTemp: TVarData;
begin
  VarDataInit(LSource);
  try
    VarDataCopyNoInd(LSource, Source);
    if VarDataIsStr(LSource) then
      TFMTBcdVarData(Dest).VBcd := TFMTBcdData.Create(VarDataToStr(LSource), 32, 8)
    else
    begin
      VarDataInit(LTemp);
      try
        VarDataCastTo(LTemp, LSource, varDouble);
        TFMTBcdVarData(Dest).VBcd := TFMTBcdData.Create(LTemp.VDouble, 32, 8);
      finally
        VarDataClear(LTemp);
      end;
    end;
    Dest.VType := VarType;
  finally
    VarDataClear(LSource);
  end;
end;

procedure TFMTBcdVariantType.CastTo(var Dest: TVarData;
  const Source: TVarData; const AVarType: TVarType);
var
  LTemp: TVarData;
begin
  if Source.VType = VarType then
    case AVarType of
      varOleStr:
        VarDataFromOleStr(Dest, TFMTBcdVarData(Source).VBcd.AsString);
      varString:
        VarDataFromStr(Dest, TFMTBcdVarData(Source).VBcd.AsString);
    else
      VarDataInit(LTemp);
      try
        LTemp.VType := varDouble;
        LTemp.VDouble := BcdToDouble(TFMTBcdVarData(Source).VBcd.Bcd);
        VarDataCastTo(Dest, LTemp, AVarType);
      finally
        VarDataClear(LTemp);
      end;
    end
  else
    inherited;
end;

procedure TFMTBcdVariantType.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
begin
  if Indirect and VarDataIsByRef(Source) then
    VarDataCopyNoInd(Dest, Source)
  else
    with TFMTBcdVarData(Dest) do
    begin
      VType := VarType;
      VBcd := TFMTBcdData.Create(TFMTBcdVarData(Source).VBcd);
    end;
end;

procedure TFMTBcdVariantType.BinaryOp(var Left: TVarData; const Right: TVarData; const Operator: TVarOp);
begin
  case Operator of
    opAdd:
      TFMTBcdVarData(Left).VBcd.DoAdd(TFMTBcdVarData(Right).VBcd);
    opSubtract:
      TFMTBcdVarData(Left).VBcd.DoSubtract(TFMTBcdVarData(Right).VBcd);
    opMultiply:
      TFMTBcdVarData(Left).VBcd.DoMultiply(TFMTBcdVarData(Right).VBcd);
    opDivide:
      TFMTBcdVarData(Left).VBcd.DoDivide(TFMTBcdVarData(Right).VBcd);
  else
    RaiseInvalidOp;
  end;
end;

function TFMTBcdVariantType.GetInstance(const V: TVarData): TObject;
begin
  Result := TFMTBcdVarData(V).VBcd;
end;

procedure TFMTBcdVariantType.Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult);
begin
  Relationship := TFMTBcdVarData(Left).VBcd.Compare(TFMTBcdVarData(Right).VBcd);
end;

{ FMTBcd variant create utils }

function VarFMTBcdCreate(const AValue: string; Precision, Scale: Word): Variant; overload;
begin
  VarClear(Result);
  TFMTBcdVarData(Result).VType := FMTBcdVariantType.VarType;
  TFMTBcdVarData(Result).VBcd := TFMTBcdData.Create(AValue, Precision, Scale);
end;

function VarFMTBcdCreate(const AValue: Double; Precision, Scale: Word): Variant; overload;
begin
  VarClear(Result);
  TFMTBcdVarData(Result).VType := FMTBcdVariantType.VarType;
  TFMTBcdVarData(Result).VBcd := TFMTBcdData.Create(AValue, Precision, Scale);
end;

procedure VarFMTBcdCreate(var ADest: Variant; const ABcd: TBcd); overload;