StrictRound.pm

package StrictRound;

# ------------------------------------------------------------------------------
# Обёртка для POSIX::round. Позволяет настраивать контроль входного параметра
# и реакцию на ошибки. Плюс обрабатывает ',' (или что ещё) как десятичную точку.
#
# Пример:
#
# use StrictRound qw/strict_round/, {
#   allow_undef   => 1,     - разрешить undef и ''
#   allow_empty   => 1,     - разрешить вызов без аргументов
#   on_errors     => 'die', - что делать при ошибках (см. %ERROR_HANDLERS, можно sub)
#   error_value   => 0,     - что возвращать при ошибках (если не бросается исключение)
#   default_value => 0,     - что возвращать при пустоте или undef на входе
#   decimal       => ','    - что ещё считать десятичной точкой
# };
#
# Как использовать:
#     say strict_round('3,1415');
#
# ------------------------------------------------------------------------------
use Modern::Perl;

# ------------------------------------------------------------------------------
use Carp qw/carp croak/;
use Const::Fast;
use POSIX qw/round/;
use Scalar::Util::LooksLikeNumber qw/looks_like_number/;

# ------------------------------------------------------------------------------
use base qw/Exporter/;
our $VERSION   = v1.011;
our @EXPORT_OK = qw/strict_round/;

# ------------------------------------------------------------------------------
const my $ARG_ERROR => 'Can receive either a hash or a hash reference';
const my $ON_ERRORS => 'on_errors';
my %ERROR_HANDLERS = (
    'die'     => sub { my $rc = sprintf shift, @_; croak $rc; },
    'warn'    => sub { my $rc = sprintf shift, @_; carp $rc; },
    'warning' => sub { my $rc = sprintf shift, @_; carp $rc; },
    'quiet'   => sub { },
    'mute'    => sub { },
    'none'    => sub { },
);

my %params = (
    allow_undef   => 0,
    allow_empty   => 0,
    $ON_ERRORS    => 'warn',
    error_value   => undef,
    default_value => 0,
    decimal       => q{,},
);

my $decimal;

# ------------------------------------------------------------------------------
sub strict_round {

    my ($number) = @_;

    if ( !@_ ) {
        return $params{default_value} if $params{allow_empty};
        return _round_error('Can not call without argument');
    }

    return _round_error('Only one argument is allowed')
        if @_ > 1;

    if ($number) {
        $number =~ s/$decimal/\./sm;
    }
    else {
        return $params{default_value} if $params{allow_undef};
    }

    return _round_error( 'Argument is not a number: "%s"', $number )
        unless looks_like_number $number;

    return round $number;
}

# ------------------------------------------------------------------------------
sub import {

    my ( $class, $tag ) = ( shift, shift );

    if (@_) {

        my $args;

        if ( @_ == 1 ) {
            $args = shift;
            croak $ARG_ERROR unless ref $args eq 'HASH';
        }
        else {
            croak $ARG_ERROR if @_ % 2;
            $args = {@_};
        }

        while ( my ( $key, $value ) = each %{$args} ) {
            croak sprintf 'Unknown argument "%s"', $key
                unless exists $params{$key};
            if ( $key eq $ON_ERRORS ) {
                if ( ref $value eq 'CODE' ) {
                    $ERROR_HANDLERS{code} = $value;
                    next;
                }
                else {
                    croak sprintf 'Invalid value "%s" for key "%s"', $value, $ON_ERRORS
                        unless exists $ERROR_HANDLERS{$value};
                }
            }
            $params{$key} = $value;
        }
    }

    $decimal = qr/[$params{decimal}]/smx;

    return $class->Exporter::export_to_level( 1, $class, $tag );
}

# ------------------------------------------------------------------------------
sub _round_error {

    if ( $ERROR_HANDLERS{code} ) {
        $ERROR_HANDLERS{code}->(@_);
    }
    else {
        $ERROR_HANDLERS{ $params{$ON_ERRORS} }->(@_);
    }
    return $params{error_value};
}

# ------------------------------------------------------------------------------
1;