File Coverage

blib/lib/Acme/Roman.pm

Criterion	Covered	Total	%
statement	35	73	47.9
branch	2	34	5.8
condition			n/a
subroutine	11	21	52.3
pod			n/a
total	48	128	37.5

package Acme::Roman;

use strict;
use warnings;

use version; our $VERSION = qv('0.0.2.12');

require Roman;
use Carp qw( croak );

use base qw( Class::Accessor );
__PACKAGE__->mk_ro_accessors( qw( roman num ) );

use overload
    '0+'     => sub { shift->num },
    '""'     => sub { shift->roman },
    '+'      => \&plus,
    '-'      => \&minus,
    '*'      => \×,
    fallback => 1
;

# aliases to Roman functions, whose names dislike me
*to_roman  = \&Roman::Roman;
*to_number = \&Roman::arabic;

sub is_roman {
    return "" if $_[0] =~ /[^IVXLCDM]/; # false: accept nothing but uppercase
    return Roman::isroman(shift);
}

sub new {
    my $proto = shift;
    my $arg   = shift;
    if ( $arg =~ /^\d+$/ ) { # looks like an arabic number
        croak __PACKAGE__, " does not like numbers above 3999" if $arg > 3999;
        return $proto->SUPER::new( { roman => Roman::Roman($arg), num => $arg } );
    } elsif ( Roman::isroman($arg) ) {
        return $proto->SUPER::new( { roman => $arg, num => Roman::arabic($arg) } );
    } else {
        croak "$arg does not look like a (roman or arabic) number";
    }
}

sub plus {
    my $r1 = shift;
    my $r2 = shift;
    my $num1 = ref $r1 ? $r1->num : is_roman($r1) ? to_number($r1) : $r1;
    my $num2 = ref $r2 ? $r2->num : is_roman($r2) ? to_number($r2) : $r2;
    return __PACKAGE__->new( $num1 + $num2 );
}

sub minus {
    my $r1 = shift;
    my $r2 = shift;
    my $num1 = ref $r1 ? $r1->num : is_roman($r1) ? to_number($r1) : $r1;
    my $num2 = ref $r2 ? $r2->num : is_roman($r2) ? to_number($r2) : $r2;
    return __PACKAGE__->new( $num1 - $num2 );
}

sub times {
    my $r1 = shift;
    my $r2 = shift;
    my $num1 = ref $r1 ? $r1->num : is_roman($r1) ? to_number($r1) : $r1;
    my $num2 = ref $r2 ? $r2->num : is_roman($r2) ? to_number($r2) : $r2;
    return __PACKAGE__->new( $num1 * $num2 );
}

use vars qw( $AUTOLOAD );

sub make_autoload {
    my $package = shift;
    return sub {
        my $sub_name = $AUTOLOAD;
        $sub_name =~ s/^.*:://;
        if ( is_roman($sub_name) ) {
            return Acme::Roman->new($sub_name);
        } else {
            croak "Undefined subroutine $AUTOLOAD called";
        }
    };
}

use Scalar::Util qw( set_prototype );

sub def_prototypes {
    my $package = shift;
    use strict;
    for ( 1..3999 ) {
        my $roman = to_roman($_);
        # sets an empty prototype
        set_prototype( \&{ "${package}::${roman}" }, '' );
        #eval "sub ${package}::${roman} (); ";
    }
}

sub import {
    my $package = caller;

    def_prototypes($package);

    my $autoload = make_autoload($package);
    no strict 'refs';
    *{ "${package}::AUTOLOAD" } = $autoload;
}

1;

__END__