{****************************************************************************
*                                                                           *
*   This file is a companion to the Free Pascal run time library.           *
*   Author : BrunoK on lazarus forum                                        *
*                                                                           *
*   This file contains some helper routines for the currency data type      *
*   that handles RoundTo_Curr, RoundTo5_Curr, Ceil_Curr and Trunc_Curr      *
*   both on CPU32 and CPU64.                                                *
*   function SimpleFmtCurr(aCurr) returns decimal raw string for aCurr)     *
*                                                                           *
*   Except DblToCurr4, functions in this unit avoid multiplication,         *
*   division and implicit datatype  conversion for better control of away   *
*   from 0 roundings.                                                       *
*                                                                           *
*   This code is free software; you can redistribute it and/or modify it.   *
*                                                                           *
*   See the file COPYING.FPC for details about the copyright.               *
*                                                                           *
*   This program is distributed in the hope that it will be useful,         *
*   but WITHOUT ANY WARRANTY; without even the implied warranty of          *
*   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                    *
*                                                                           *
*****************************************************************************}

unit CurrUtil;

{$mode objfpc}{$H+}

interface

type
  TCurrRoundRange = -3..14;

{ Raw currency formatting avoiding conversion to Float }
function SimpleFmtCurr(constref aCur : currency) : string;

{ Int64 only based functions. Avoids use of float for currencies }
function RoundTo_Curr(constref aCurr : Currency; const a10EFact : TCurrRoundRange = -2) : Currency;
function RoundTo5_Curr(constref aCurr : Currency; const a10EFact : TCurrRoundRange= -2) : Currency;
function Ceil_Curr(const aCurr : Currency) : Currency;
function Trunc_Curr(const aCurr : Currency) : Currency;
function DblToCurr4(const aDBl : double) : Currency;

implementation

uses
  Math;

const
  cModFact:array[TCurrRoundRange] of int64 =
    (10, 100, 1000,    // Decimals
     10000,            // Unit
     100000,           // Powers of 10
     1000000,
     10000000,
     100000000,
     1000000000,
     10000000000,
     100000000000,
     1000000000000,
     10000000000000,
     100000000000000,
     1000000000000000,
     10000000000000000,
     100000000000000000,
     1000000000000000000);
    {9223372036854775807}

  c10e4   = 10000;
  c2x10e5 = 20000;

{ Raw formatting currency without using FormatCurr }
function SimpleFmtCurr(constref aCur : currency) : string;
const
  c0Str : string[3] = '000';
var
  lI64C : int64 absolute aCur;
  lCString : ShortString;
  lLen : integer;
  lNegative : boolean;
begin
  lNegative := lI64C<0;
  if lNegative then begin
    {$PUSH} {$Q+}           // Protect overflow
    str(-lI64C, lCString);
    {$POP}
    Result := '-';
  end
  else begin
    str(lI64C, lCString);
    Result := '';
  end;
  lLen := Length(lCString);
  if lLen<5 then
    Result := Result + '0.' + copy(c0Str, 1, 4 - lLen) + lCString
  else
    Result := Result + copy(lCString, 1, lLen-4) + '.' + copy(lCString, lLen-3, 4);
end;

{ Internal utility to return a positive Int64, raises an exception
  if aCurr = Low(Currency) }
function ExtractParts(constref aCurr: Currency; out aoNegative : boolean)
        : int64;
var
  lInInt64 : Int64 absolute aCurr;
begin
  aoNegative := False;
  Result := lInInt64;
  if Result < 0 then begin // Make work var positive
    aoNegative := True;
  {$PUSH} {$Q+}           // Protect overflow
    Result := -Result;
  {$POP}
  end;
end;

{ RoundTo_Curr : round away from 0 to -n decimal places }
function RoundTo_Curr(constref aCurr: Currency; const a10EFact: TCurrRoundRange
  ): Currency;
var
  lNegative : boolean;
  lModFact : Int64;
  lRem : int64;

  lResInt64 : Int64 absolute Result;
begin
  if aCurr = 0 then
    Exit(0);
  lResInt64 := ExtractParts(aCurr, lNegative);
  lModFact := cModFact[a10EFact];
  lRem := lResInt64 mod lModFact;
  if lRem>0 then begin
    lResInt64 := lResInt64 - lRem; // Trunc
    if lRem>=(lModFact shr 1) then
      {$PUSH} {$Q+}// Protect overflow
      lResInt64 := lResInt64 + lModFact;
      {$POP}
  end;
  if lNegative then
    Result := -Result;
end;

{ RoundTo5_Curr : round to 5 cents (or other -n RoundRange) away from 0
                  decimal places }
function RoundTo5_Curr(constref aCurr: Currency; const a10EFact: TCurrRoundRange
  ): Currency;
var
  lNegative : boolean;
  lModFact : Int64;
  lRem : int64;

  lResInt64 : Int64 absolute Result;
begin
  if aCurr = 0 then
    Exit(0);
  lResInt64 := ExtractParts(aCurr, lNegative);
  lModFact := cModFact[a10EFact + 1] shr 1;
  lRem := lResInt64 mod lModFact;
  if lRem>0 then begin
    lResInt64 := lResInt64 - lRem; // Trunc
    if lRem>=(lModFact shr 1) then
      {$PUSH} {$Q+}// Protect overflow
      lResInt64 := lResInt64 + lModFact;
      {$POP}
  end;
  if lNegative then
    Result := -Result;
end;

function Ceil_Curr(const aCurr: Currency): Currency;
var
  lNegative : boolean;
  lRem : int64;

  lResInt64 : Int64 absolute Result;
begin
  if aCurr = 0 then
    Exit(0);
  lResInt64 := ExtractParts(aCurr, lNegative);
  lRem := lResInt64 mod c10E4;
  if lRem > 0 then begin
    lResInt64 := lResInt64 - lRem;  // Trunc
    {$PUSH} {$Q+}        // Protect overflow
    lResInt64 := lResInt64 + c10E4;
    {$POP}
  end;
  if lNegative then
    Result := -Result;
end;

function Trunc_Curr(const aCurr: Currency): Currency;
var
  lNegative : boolean;
  lRem : int64;

  lResInt64 : Int64 absolute Result;
begin
  if aCurr = 0 then
    Exit(0);
  lResInt64 := ExtractParts(aCurr, lNegative);
  lRem := lResInt64 mod c10E4;
  lResInt64 := lResInt64 - lRem;  // Trunc
  if lNegative then
    Result := -Result;
end;

{ Conversion from Double to Currency with away from 0 rounding to 4 decimal
  places }
function DblToCurr4(const aDBl: double): Currency;
var
  lDbl : Double;

  lNegative : boolean;
  lRem : int64;

  lResInt64 : Int64 absolute Result;
begin
  if aDBl = 0 then
    Exit(0);
  lResInt64 := Trunc(Int(aDbl * c2x10e5));
  lResInt64 := ExtractParts(Result, lNegative);
  lResInt64 := (lResInt64 + 1) shr 1;
  if lNegative then
    Result := -Result;
end;

end.