Add a benchmark for duck_type

[gitmo/Mouse.git] / benchmarks / type_constraints.pl

#!perl
use strict;
use Benchmark qw(:all);
use Config; printf "Perl/%vd in $Config{archname}\n\n", $^V;
use warnings;
no warnings 'once';

my $cxsa_is_loaded = eval q{
    package CXSA;
    use Class::XSAccessor
        constructor => 'new',
        accessors   => {
            simple => 'simple',
        },
    ;
    1;
};

{
    package Foo;
    sub new { bless {}, shift }
}

{
    package MouseOne;
    use Mouse;
    use Mouse::Util::TypeConstraints;
    has simple => (
        is => 'rw',
    );
    has with_lazy => (
        is      => 'rw',
        lazy    => 1,
        default => 42,
    );
    has with_tc => (
        is  => 'rw',
        isa => 'Int',
    );

    has with_tc_class_type => (
        is  => 'rw',
        isa => 'Foo',
    );

    has with_tc_array_of_int => (
        is  => 'rw',
        isa => 'ArrayRef[Int]',
    );

    has with_tc_duck_type => (
        is  => 'rw',
        isa => duck_type([qw(simple)]),
    );
    __PACKAGE__->meta->make_immutable;
}
{
    package MooseOne;
    use Moose;
    use Moose::Util::TypeConstraints;
    has simple => (
        is => 'rw',
    );
    has with_lazy => (
        is      => 'rw',
        lazy    => 1,
        default => 42,
    );
    has with_tc => (
        is  => 'rw',
        isa => 'Int',
    );
    has with_tc_class_type => (
        is  => 'rw',
        isa => 'Foo',
    );
    has with_tc_array_of_int => (
        is  => 'rw',
        isa => 'ArrayRef[Int]',
    );
    has with_tc_duck_type => (
        is  => 'rw',
        isa => duck_type([qw(simple)]),
    );

    __PACKAGE__->meta->make_immutable;
}

use B qw(svref_2object);

print "Moose/$Moose::VERSION (Class::MOP/$Class::MOP::VERSION)\n";
print "Mouse/$Mouse::VERSION\n";
print "Class::XSAccessor/$Class::XSAccessor::VERSION\n" if $cxsa_is_loaded;

my $mi = MouseOne->new();
my $mx = MooseOne->new();
my $cx;
$cx = CXSA->new       if $cxsa_is_loaded;

print "\nSETTING for simple attributes\n";
cmpthese -1 => {
    'Mouse' => sub{
        $mi->simple(10);
        $mi->simple(10);
    },
    'Moose' => sub{
        $mx->simple(10);
        $mx->simple(10);
    },
    $cxsa_is_loaded ? (
    'C::XSAccessor' => sub{
        $cx->simple(10);
        $cx->simple(10);
    },
    ) : (),

};

print "\nSETTING for attributes with type constraints 'Int' (except for C::XSAccessor)\n";
cmpthese -1 => {
    'Mouse' => sub{
        $mi->with_tc(10);
        $mi->with_tc(10);
    },
    'Moose' => sub{
        $mx->with_tc(10);
        $mx->with_tc(10);
    },
    $cxsa_is_loaded ? (
    'C::XSAccessor' => sub{
        $cx->simple(10);
        $cx->simple(10);
    },
    ) : (),
};

print "\nSETTING for attributes with type constraints 'Foo' (except for C::XSAccessor)\n";
my $foo = Foo->new;
cmpthese -1 => {
    'Mouse' => sub{
        $mi->with_tc_class_type($foo);
        $mi->with_tc_class_type($foo);
    },
    'Moose' => sub{
        $mx->with_tc_class_type($foo);
        $mx->with_tc_class_type($foo);
    },
    $cxsa_is_loaded ? (
    'C::XSAccessor' => sub{
        $cx->simple($foo);
        $cx->simple($foo);
    },
    ) : (),
};

print "\nSETTING for attributes with type constraints 'ArrayRef[Int]' (except for C::XSAccessor)\n";

$foo = [10, 20];
cmpthese -1 => {
    'Mouse' => sub{
        $mi->with_tc_array_of_int($foo);
        $mi->with_tc_array_of_int($foo);
    },
    'Moose' => sub{
        $mx->with_tc_array_of_int($foo);
        $mx->with_tc_array_of_int($foo);
    },
    $cxsa_is_loaded ? (
    'C::XSAccessor' => sub{
        $cx->simple($foo);
        $cx->simple($foo);
    },
    ) : (),
};

print "\nSETTING for attributes with type constraints duck_type() (except for C::XSAccessor)\n";

$foo = MouseOne->new();
cmpthese -1 => {
    'Mouse' => sub{
        $mi->with_tc_duck_type($foo);
        $mi->with_tc_duck_type($foo);
    },
    'Moose' => sub{
        $mx->with_tc_duck_type($foo);
        $mx->with_tc_duck_type($foo);
    },
    $cxsa_is_loaded ? (
    'C::XSAccessor' => sub{
        $cx->simple($foo);
        $cx->simple($foo);
    },
    ) : (),
};