root/lang/perl/Shika/trunk/benchmark/new-get-set.pl @ 25792

use strict;
use warnings;

{
    package MooseImmutableBuild;
    use Moose;

    has userid => (
        is => 'rw',
    );

    has agent  => (
        is => 'rw',
        required => 1,
    );

    sub BUILD {
        my $self = shift;
        $self->userid(90);
        $self->userid($self->agent->user_id ) unless $self->agent->is_non_mobile;
    }

    no Moose;
    __PACKAGE__->meta->make_immutable;
    1;
}

{
    package MooseImmutableDefault;
    use Moose;

    has userid => (
        is      => 'rw',
        lazy    => 1,
        default => sub {
            my $self = shift;
            return $self->agent->is_non_mobile ? 90 : $self->agent->user_id;
        }
    );

    has agent  => (
        is       => 'rw',
        required => 1,
    );

    no Moose;
    __PACKAGE__->meta->make_immutable;
    1;
}

{
    package MouseImmutableDefault;
    use Mouse;

    has userid => (
        is      => 'rw',
        lazy    => 1,
        default => sub {
            my $self = shift;
            return $self->agent->is_non_mobile ? 90 : $self->agent->user_id;
        }
    );

    has agent  => (
        is       => 'rw',
        required => 1,
    );

    no Mouse;
    __PACKAGE__->meta->make_immutable;
    1;
}

{
    package MouseDefault;
    use Mouse;

    has userid => (
        is      => 'rw',
        lazy    => 1,
        default => sub {
            my $self = shift;
            return $self->agent->is_non_mobile ? 90 : $self->agent->user_id;
        }
    );

    has agent  => (
        is       => 'rw',
        required => 1,
    );

    no Mouse;
    1;
}

{
    package ShikaDefault;
    use Shika;

    has userid => (
        is      => 'rw',
        lazy    => 1,
        default => sub {
            my $self = shift;
            return $self->agent->is_non_mobile ? 90 : $self->agent->user_id;
        }
    );

    has agent  => (
        is       => 'rw',
        required => 1,
    );

    no Shika;
    1;
}

{
    package ClassAccessor;
    use strict;
    use warnings;
    use base qw/Class::Accessor::Fast/;
    use Carp qw/croak/;

    __PACKAGE__->mk_accessors(qw/
        userid
        agent
    /);

    sub new {
        my $self = shift->SUPER::new(@_);
        $self->agent or croak 'agent not found';
        $self->userid( 90 );
        $self->userid( $self->agent->user_id ) unless $self->agent->is_non_mobile;
        return $self;
    }
}

{
    package Popo;
    sub new {
        my $class = shift;
        my $param = ref $_[0] eq 'HASH' ? shift : {@_};
        return bless $param, ref $class || $class;
    }

    sub agent {
        my $self = shift;
        return $self->{agent} = shift if @_;
        return $self->{agent};
    }

    sub userid {
        my $self = shift;
        return $self->{userid} = shift if @_;
        exists $self->{userid} || do {
            $self->{userid} = $self->agent->is_non_mobile ? 90 : $self->agent->user_id;
        };
        return $self->{userid};
    }
}

package main;

use HTTP::MobileAgent;
my $agent = HTTP::MobileAgent->new('');

use Benchmark qw(cmpthese timethese :hireswallclock);

#    my $obj1 = MooseBuild->new( agent => $agent );
#    my $obj2 = MooseDefault->new( agent => $agent );
#    my $obj3 = ClassAccessor->new({ agent => $agent });
#    my $obj4 = Popo->new( agent => $agent );
#    my $obj5 = ShikaDefault->new( agent => $agent );

{
    no strict 'refs';
    for my $key (qw/Moose Class::MOP Mouse Shika/) {
        my $version = ${"$key\::VERSION"};
        print "$key: $version\n";
    }
}

my @classes = qw/MooseImmutableBuild MooseImmutableDefault MouseImmutableDefault MouseDefault ShikaDefault ClassAccessor Popo/;

print "------ new,get,set\n";
cmpthese(-1,{
    map { my $x = $_; $_ => sub {
        my $obj = $x->new( {agent => $agent} );
        $obj->userid;
        $obj->userid('hoge');
    }} @classes
});
print "------ new\n";
cmpthese(-1,{
    map { my $x = $_; $_ => sub {
        $x->new( {agent => $agent} );
    }} @classes
});
print "------ new,get\n";
cmpthese(-1,{
    map { my $x = $_; $_ => sub {
        my $obj = $x->new( {agent => $agent} );
        $obj->userid();
    }} @classes
});
print "----1 new,set\n";
cmpthese(10000,{
    map { my $x = $_; $_ => sub {
        my $obj = $x->new( {agent => $agent} );
        $obj->userid('hoge');
    }} @classes
});