#!/usr/bin/perl
    
use strict;
use warnings;
    
use Benchmark qw /cmpthese/;
use Carp;

package Class_Closure;

sub new {
    my $class  = shift;
    my %args   = @_;
    my %field  = (
        name   => $args {name}   || "abigail",
        colour => $args {colour} || "pink",
        age    => $args {age}    ||  100,
        class  => $class,
    );  
 
    bless sub {
        my $name = shift;
    
        my ($package, $filename, $line) = caller;
    
        die "Attempt to access private class data " .
                "for $field{class} at $filename line $line\n"
                unless UNIVERSAL::isa ($package => __PACKAGE__);
        die "No such field '$name' at $filename line $line\n"
                unless exists $field{$name};
        die "You can't change the class name at $filename line $line\n"
                if $name eq 'class';
    
        $field {$name} = shift if @_;
        $field {$name}
    } => $class;
}   
sub name   {my $self = shift; $self -> (name   => @_)}
sub colour {my $self = shift; $self -> (colour => @_)}
sub age    {my $self = shift; $self -> (age    => @_)}
sub format {
    my $self = shift;
    join " " => $self -> ('name'), $self -> ('colour'), $self -> ('age');
}
    
package Class_Inside_Out;
        
my %name;
my %colour;
my %age;
        
sub new {
    my $key        = bless \(my $dummy) => shift;
    my %args       = @_; 
    $name   {$key} = $args {name}   || "abigail";
    $colour {$key} = $args {colour} || "pink";   
    $age    {$key} = $args {age}    ||  100;
        
    $key;
}
        
sub name {
    my $key = shift;
    $name {$key} = shift if @_;
    $name {$key};
}
        
sub colour {
    my $key = shift;
    $colour {$key} = shift if @_;
    $colour {$key};
}

sub age {
    my $key = shift;
    $age {$key} = shift if @_;
    $age {$key};
}
        
sub format {
    my $key = shift;
    join " " => $name {$key}, $colour {$key}, $age {$key};
}       

package Class_Traditional;
    
sub new {
    my $class = shift;
    my %args  = @_;
    bless {name   => $args {name}   || "abigail",
           colour => $args {colour} || "pink",
           age    => $args {age}    ||  100} => $class;
}       

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

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

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

sub format {
    my $self = shift;
    join " " => @$self {qw /name colour age/};
}

    
package main;
    
    
our $obj_c = Class_Closure     -> new;
our $obj_i = Class_Inside_Out  -> new;
our $obj_t = Class_Traditional -> new;
        
our @names   = ("Larry Wall", "Damian Conway", "Nicholas Clark",
                "Gurusamy Sarathy", "Chip Salzenberg",
                "Rafael Garcia-Suarez");
our @colours = qw /red green blue white yellow orange brown purple violet/;
    
#       
# Test.
#
my $name   = $names [rand @names];
my $colour = $colours [rand @colours];
my $age    = 1 + int rand 100;
 
foreach my $i ([obj_c => $obj_c], [obj_i => $obj_i], [obj_t => $obj_t]) {
    $i -> [1] -> name   ($name);
    $i -> [1] -> colour ($colour);
    $i -> [1] -> age    ($age);  
    die $i -> [0] unless "$name $colour $age" eq $i -> [1] -> format;
}       


our $dummy;
cmpthese -1 => {
    closure =>    'foreach my $n (@names) {
                       foreach my $c (@colours) {
                           my $age = 1 + int rand 100;
                           $obj_c -> name ($n);
                           $obj_c -> colour ($c);
                           $obj_c -> age ($age);
                           $dummy = $obj_c -> format;
                       }
                   }',
    inside_out => 'foreach my $n (@names) {
                       foreach my $c (@colours) {
                           my $age = 1 + int rand 100;
                           $obj_i -> name ($n);
                           $obj_i -> colour ($c);
                           $obj_i -> age ($age);
                           $dummy = $obj_i -> format;
                       }
                   }',
    traditional => 'foreach my $n (@names) {
                       foreach my $c (@colours) {
                           my $age = 1 + int rand 100;
                           $obj_t -> name ($n);
                           $obj_t -> colour ($c);
                           $obj_t -> age ($age);
                           $dummy = $obj_t -> format;
                       }
                   }',
};      

__END__
              Rate     closure  inside_out traditional
closure      355/s          --        -25%        -75%
inside_out   473/s         33%          --        -67%
traditional 1436/s        304%        203%          --