benchmarks/type_constraints.pl

   1 #!perl
   2 use strict;
   3 use Benchmark qw(:all);
   4 use Config; printf "Perl/%vd in $Config{archname}\n\n", $^V;
   5 use warnings;
   6 no warnings 'once';
   7
   8 my $cxsa_is_loaded = eval q{
   9     package CXSA;
  10     use Class::XSAccessor
  11         constructor => 'new',
  12         accessors   => {
  13             simple => 'simple',
  14         },
  15     ;
  16     1;
  17 };
  18
  19 {
  20     package Foo;
  21     sub new { bless {}, shift }
  22 }
  23
  24 {
  25     package MouseOne;
  26     use Mouse;
  27     has simple => (
  28         is => 'rw',
  29     );
  30     has with_lazy => (
  31         is      => 'rw',
  32         lazy    => 1,
  33         default => 42,
  34     );
  35     has with_tc => (
  36         is  => 'rw',
  37         isa => 'Int',
  38     );
  39
  40     has with_tc_class_type => (
  41         is  => 'rw',
  42         isa => 'Foo',
  43     );
  44
  45     has with_tc_array_of_int => (
  46         is  => 'rw',
  47         isa => 'ArrayRef[Int]',
  48     );
  49     __PACKAGE__->meta->make_immutable;
  50 }
  51 {
  52     package MooseOne;
  53     use Moose;
  54     has simple => (
  55         is => 'rw',
  56     );
  57     has with_lazy => (
  58         is      => 'rw',
  59         lazy    => 1,
  60         default => 42,
  61     );
  62     has with_tc => (
  63         is  => 'rw',
  64         isa => 'Int',
  65     );
  66     has with_tc_class_type => (
  67         is  => 'rw',
  68         isa => 'Foo',
  69     );
  70     has with_tc_array_of_int => (
  71         is  => 'rw',
  72         isa => 'ArrayRef[Int]',
  73     );
  74
  75     __PACKAGE__->meta->make_immutable;
  76 }
  77
  78 use B qw(svref_2object);
  79
  80 print "Moose/$Moose::VERSION (Class::MOP/$Class::MOP::VERSION)\n";
  81 print "Mouse/$Mouse::VERSION\n";
  82 print "Class::XSAccessor/$Class::XSAccessor::VERSION\n" if $cxsa_is_loaded;
  83
  84 my $mi = MouseOne->new();
  85 my $mx = MooseOne->new();
  86 my $cx;
  87 $cx = CXSA->new       if $cxsa_is_loaded;
  88
  89 print "\nSETTING for simple attributes\n";
  90 cmpthese -1 => {
  91     'Mouse' => sub{
  92         $mi->simple(10);
  93         $mi->simple(10);
  94     },
  95     'Moose' => sub{
  96         $mx->simple(10);
  97         $mx->simple(10);
  98     },
  99     $cxsa_is_loaded ? (
 100     'C::XSAccessor' => sub{
 101         $cx->simple(10);
 102         $cx->simple(10);
 103     },
 104     ) : (),
 105
 106 };
 107
 108 print "\nSETTING for attributes with type constraints 'Int' (except for C::XSAccessor)\n";
 109 cmpthese -1 => {
 110     'Mouse' => sub{
 111         $mi->with_tc(10);
 112         $mi->with_tc(10);
 113     },
 114     'Moose' => sub{
 115         $mx->with_tc(10);
 116         $mx->with_tc(10);
 117     },
 118     $cxsa_is_loaded ? (
 119     'C::XSAccessor' => sub{
 120         $cx->simple(10);
 121         $cx->simple(10);
 122     },
 123     ) : (),
 124 };
 125
 126 print "\nSETTING for attributes with type constraints 'Foo' (except for C::XSAccessor)\n";
 127 my $foo = Foo->new;
 128 cmpthese -1 => {
 129     'Mouse' => sub{
 130         $mi->with_tc_class_type($foo);
 131         $mi->with_tc_class_type($foo);
 132     },
 133     'Moose' => sub{
 134         $mx->with_tc_class_type($foo);
 135         $mx->with_tc_class_type($foo);
 136     },
 137     $cxsa_is_loaded ? (
 138     'C::XSAccessor' => sub{
 139         $cx->simple($foo);
 140         $cx->simple($foo);
 141     },
 142     ) : (),
 143 };
 144
 145 print "\nSETTING for attributes with type constraints 'ArrayRef[Int]' (except for C::XSAccessor)\n";
 146
 147 $foo = [10, 20];
 148 cmpthese -1 => {
 149     'Mouse' => sub{
 150         $mi->with_tc_array_of_int($foo);
 151         $mi->with_tc_array_of_int($foo);
 152     },
 153     'Moose' => sub{
 154         $mx->with_tc_array_of_int($foo);
 155         $mx->with_tc_array_of_int($foo);
 156     },
 157     $cxsa_is_loaded ? (
 158     'C::XSAccessor' => sub{
 159         $cx->simple($foo);
 160         $cx->simple($foo);
 161     },
 162     ) : (),
 163 };