File Coverage

blib/lib/Text/Roman.pm

Criterion	Covered	Total	%
statement	57	57	100.0
branch	29	30	96.6
condition	9	11	81.8
subroutine	11	11	100.0
pod	5	5	100.0
total	111	114	97.3

package Text::Roman;
# ABSTRACT: Allows conversion between Roman and Arabic algarisms.


use strict;
use warnings qw(all);

use Carp qw(carp);
use Exporter;

## no critic (ProhibitAutomaticExportation, ProhibitExplicitISA)
our @ISA            = qw(Exporter);
our %EXPORT_TAGS    = (all => [qw(roman int2roman roman2int isroman mroman2int milhar2int ismroman ismilhar)]);
our @EXPORT_OK      = @{$EXPORT_TAGS{all}};

our $VERSION = '3.5'; # VERSION

our @RSN = qw/I V X L C D M/;                           # Roman Simple Numerals
our @RCN = qw/IV IX XL XC CD CM/;                       # Roman Complex Numerals
our %R2A;
@R2A{@RSN, @RCN} = qw/
    1 5 10 50 100 500 1000 4 9 40 90 400 900
/;                                                      # numeric values
our %A2R = reverse %R2A;                                # reverse for convenience


## no critic (RequireArgUnpacking)
sub isroman {
    local $_ = uc(@_ ? shift : $_);

    return if !/^[@RSN]+$/x;
    return if /([IXCM])\1{3,}|([VLD])\2+/x;             # tests repeatability
    my @re = qw/IXI|XCX|CMC/;
    for (1 .. $#RSN) {
        push @re, "$RSN[$_ - 1]$RSN[$_]$RSN[$_ - 1]";   # tests IVI
        push @re, "$RSN[$_]$RSN[$_ - 1]$RSN[$_]";       # and VIV conditions
    }
    my $re = join "|", @re;
    return !/$re/x;
}


sub int2roman {
    my $n = @_ ? shift : $_;
    return
        if not $n =~ /^[0-9]+$/x
        or $n <= 0
        or $n >= 4000;

    my $ret = '';
    for (reverse sort { $a <=> $b } values %R2A) {
        $ret .= $A2R{$_} x int($n / $_);
        $n %= $_;
    }

    return defined(wantarray)
        ? $ret
        : $_ = $ret;
}


sub roman2int {
    my $ret = 0;
    do {
        local $_ = uc(@_ ? shift : $_);

        return unless isroman();

        my ($r, $_ret) = ($_, 0);
        while ($r) {
            $r =~ s/^$_//x and ($ret += $R2A{$_}, last) for @RCN, @RSN;
            return if $ret <= $_ret;
            $_ret = $ret;
        }
    };

    return defined(wantarray)
        ? $ret
        : $_ = $ret;
}


sub ismilhar {
    local $_ = uc(@_ ? shift : $_);
    return unless /^[_@RSN]+$/x;

    my @r = split /_/;
    isroman() || return for @r;
    return 1;
}


sub milhar2int {
    my $ret;
    do {
        local $_ = uc(@_ ? shift : $_);

        return unless ismilhar();

        my @r = split /_/;
        $ret = roman2int(pop @r);
        $ret += 1000 * roman2int() for @r;
    };

    return defined(wantarray)
        ? $ret
        : $_ = $ret;
}


my %deprecated = (
    ismroman    => [ ismilhar   => \&ismilhar   ],
    mroman2int  => [ milhar2int => \&milhar2int ],
    roman       => [ int2roman  => \&int2roman  ],
);

for my $aliased (keys %deprecated) {
    ## no critic (ProhibitNoStrict)
    no strict 'refs';
    *{'Text::Roman::' . $aliased} = sub {
        carp sprintf(
            '%s() deprecated, use %s() instead',
            $aliased, $deprecated{$aliased}->[0]
        );
        goto $deprecated{$aliased}->[1];
    };
}

1;

__END__