More tests for native traits to exercise all code paths

[gitmo/Moose.git] / t / 070_native_traits / 060_trait_number.t

#!/usr/bin/perl

use strict;
use warnings;

use Moose ();
use Moose::Util::TypeConstraints;
use Test::Exception;
use Test::More;
use Test::Moose;

{
    my %handles = (
        abs         => 'abs',
        add         => 'add',
        inc         => [ add => 1 ],
        div         => 'div',
        cut_in_half => [ div => 2 ],
        mod         => 'mod',
        odd         => [ mod => 2 ],
        mul         => 'mul',
        set         => 'set',
        sub         => 'sub',
        dec         => [ sub => 1 ],
    );

    my $name = 'Foo1';

    sub build_class {
        my %attr = @_;

        my $class = Moose::Meta::Class->create(
            $name++,
            superclasses => ['Moose::Object'],
        );

        $class->add_attribute(
            integer => (
                traits  => ['Number'],
                is      => 'ro',
                isa     => 'Int',
                default => 5,
                handles => \%handles,
                clearer => '_clear_integer',
                %attr,
            ),
        );

        return ( $class->name, \%handles );
    }
}

{
    run_tests(build_class);
    run_tests( build_class( lazy => 1 ) );

    # Will force the inlining code to check the entire hashref when it is modified.
    subtype 'MyInt', as 'Int', where { 1 };

    run_tests( build_class( isa => 'MyInt' ) );

    coerce 'MyInt', from 'Int', via { $_ };

    run_tests( build_class( isa => 'MyInt', coerce => 1 ) );
}

sub run_tests {
    my ( $class, $handles ) = @_;

    can_ok( $class, $_ ) for sort keys %{$handles};

    with_immutable {
        my $obj = $class->new;

        is( $obj->integer, 5, 'Default to five' );

        $obj->add(10);

        is( $obj->integer, 15, 'Add ten for fithteen' );

        throws_ok { $obj->add( 10, 2 ) }
        qr/Cannot call add with more than 1 argument/,
            'add throws an error when 2 arguments are passed';

        $obj->sub(3);

        is( $obj->integer, 12, 'Subtract three for 12' );

        throws_ok { $obj->sub( 10, 2 ) }
        qr/Cannot call sub with more than 1 argument/,
            'sub throws an error when 2 arguments are passed';

        $obj->set(10);

        is( $obj->integer, 10, 'Set to ten' );

        throws_ok { $obj->set( 10, 2 ) }
        qr/Cannot call set with more than 1 argument/,
            'set throws an error when 2 arguments are passed';

        $obj->div(2);

        is( $obj->integer, 5, 'divide by 2' );

        throws_ok { $obj->div( 10, 2 ) }
        qr/Cannot call div with more than 1 argument/,
            'div throws an error when 2 arguments are passed';

        $obj->mul(2);

        is( $obj->integer, 10, 'multiplied by 2' );

        throws_ok { $obj->mul( 10, 2 ) }
        qr/Cannot call mul with more than 1 argument/,
            'mul throws an error when 2 arguments are passed';

        $obj->mod(2);

        is( $obj->integer, 0, 'Mod by 2' );

        throws_ok { $obj->mod( 10, 2 ) }
        qr/Cannot call mod with more than 1 argument/,
            'mod throws an error when 2 arguments are passed';

        $obj->set(7);

        $obj->mod(5);

        is( $obj->integer, 2, 'Mod by 5' );

        $obj->set(-1);

        $obj->abs;

        throws_ok { $obj->abs(10) }
        qr/Cannot call abs with any arguments/,
            'abs throws an error when an argument is passed';

        is( $obj->integer, 1, 'abs 1' );

        $obj->set(12);

        $obj->inc;

        is( $obj->integer, 13, 'inc 12' );

        $obj->dec;

        is( $obj->integer, 12, 'dec 13' );

        if ( $class->meta->get_attribute('integer')->is_lazy ) {
            my $obj = $class->new;

            $obj->add(2);

            is( $obj->integer, 7, 'add with lazy default' );

            $obj->_clear_integer;

            $obj->mod(2);

            is( $obj->integer, 1, 'mod with lazy default' );
        }
    }
    $class;
}

done_testing;