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     use Mouse::Util::TypeConstraints;
  28     has simple => (
  29         is => 'rw',
  30     );
  31     has with_lazy => (
  32         is      => 'rw',
  33         lazy    => 1,
  34         default => 42,
  35     );
  36     has with_tc => (
  37         is  => 'rw',
  38         isa => 'Int',
  39     );
  40
  41     has with_tc_class_type => (
  42         is  => 'rw',
  43         isa => 'Foo',
  44     );
  45
  46     has with_tc_array_of_int => (
  47         is  => 'rw',
  48         isa => 'ArrayRef[Int]',
  49     );
  50
  51     has with_tc_duck_type => (
  52         is  => 'rw',
  53         isa => duck_type([qw(simple)]),
  54     );
  55     __PACKAGE__->meta->make_immutable;
  56 }
  57 {
  58     package MooseOne;
  59     use Moose;
  60     use Moose::Util::TypeConstraints;
  61     has simple => (
  62         is => 'rw',
  63     );
  64     has with_lazy => (
  65         is      => 'rw',
  66         lazy    => 1,
  67         default => 42,
  68     );
  69     has with_tc => (
  70         is  => 'rw',
  71         isa => 'Int',
  72     );
  73     has with_tc_class_type => (
  74         is  => 'rw',
  75         isa => 'Foo',
  76     );
  77     has with_tc_array_of_int => (
  78         is  => 'rw',
  79         isa => 'ArrayRef[Int]',
  80     );
  81     has with_tc_duck_type => (
  82         is  => 'rw',
  83         isa => duck_type([qw(simple)]),
  84     );
  85
  86     __PACKAGE__->meta->make_immutable;
  87 }
  88
  89 use B qw(svref_2object);
  90
  91 print "Moose/$Moose::VERSION (Class::MOP/$Class::MOP::VERSION)\n";
  92 print "Mouse/$Mouse::VERSION\n";
  93 print "Class::XSAccessor/$Class::XSAccessor::VERSION\n" if $cxsa_is_loaded;
  94
  95 my $mi = MouseOne->new();
  96 my $mx = MooseOne->new();
  97 my $cx;
  98 $cx = CXSA->new       if $cxsa_is_loaded;
  99
 100 print "\nSETTING for simple attributes\n";
 101 cmpthese -1 => {
 102     'Mouse' => sub{
 103         $mi->simple(10);
 104         $mi->simple(10);
 105     },
 106     'Moose' => sub{
 107         $mx->simple(10);
 108         $mx->simple(10);
 109     },
 110     $cxsa_is_loaded ? (
 111     'C::XSAccessor' => sub{
 112         $cx->simple(10);
 113         $cx->simple(10);
 114     },
 115     ) : (),
 116
 117 };
 118
 119 print "\nSETTING for attributes with type constraints 'Int' (except for C::XSAccessor)\n";
 120 cmpthese -1 => {
 121     'Mouse' => sub{
 122         $mi->with_tc(10);
 123         $mi->with_tc(10);
 124     },
 125     'Moose' => sub{
 126         $mx->with_tc(10);
 127         $mx->with_tc(10);
 128     },
 129     $cxsa_is_loaded ? (
 130     'C::XSAccessor' => sub{
 131         $cx->simple(10);
 132         $cx->simple(10);
 133     },
 134     ) : (),
 135 };
 136
 137 print "\nSETTING for attributes with type constraints 'Foo' (except for C::XSAccessor)\n";
 138 my $foo = Foo->new;
 139 cmpthese -1 => {
 140     'Mouse' => sub{
 141         $mi->with_tc_class_type($foo);
 142         $mi->with_tc_class_type($foo);
 143     },
 144     'Moose' => sub{
 145         $mx->with_tc_class_type($foo);
 146         $mx->with_tc_class_type($foo);
 147     },
 148     $cxsa_is_loaded ? (
 149     'C::XSAccessor' => sub{
 150         $cx->simple($foo);
 151         $cx->simple($foo);
 152     },
 153     ) : (),
 154 };
 155
 156 print "\nSETTING for attributes with type constraints 'ArrayRef[Int]' (except for C::XSAccessor)\n";
 157
 158 $foo = [10, 20];
 159 cmpthese -1 => {
 160     'Mouse' => sub{
 161         $mi->with_tc_array_of_int($foo);
 162         $mi->with_tc_array_of_int($foo);
 163     },
 164     'Moose' => sub{
 165         $mx->with_tc_array_of_int($foo);
 166         $mx->with_tc_array_of_int($foo);
 167     },
 168     $cxsa_is_loaded ? (
 169     'C::XSAccessor' => sub{
 170         $cx->simple($foo);
 171         $cx->simple($foo);
 172     },
 173     ) : (),
 174 };
 175
 176 print "\nSETTING for attributes with type constraints duck_type() (except for C::XSAccessor)\n";
 177
 178 $foo = MouseOne->new();
 179 cmpthese -1 => {
 180     'Mouse' => sub{
 181         $mi->with_tc_duck_type($foo);
 182         $mi->with_tc_duck_type($foo);
 183     },
 184     'Moose' => sub{
 185         $mx->with_tc_duck_type($foo);
 186         $mx->with_tc_duck_type($foo);
 187     },
 188     $cxsa_is_loaded ? (
 189     'C::XSAccessor' => sub{
 190         $cx->simple($foo);
 191         $cx->simple($foo);
 192     },
 193     ) : (),
 194 };