01_objects.pl

#!/usr/bin/perl
use warnings;
use strict;
use lib qw/lib/;
use Test::More tests => 41;

#------------------------------- Object::Simple -------------------------------
use Object::Simple;

my $o = Object::Simple->new(1);
isa_ok $o, 'Object::Simple';
ok $o->{id} == 1,     'simple object id';
is $o->{name},    '', 'simple object name';

$o->{name} = 'Homer'; # get/set via the blessed hash ref

#------------------------ Object::HandRolledAccessors -------------------------
use Object::HandRolledAccessors;

$o = Object::HandRolledAccessors->new(2);
isa_ok $o, 'Object::HandRolledAccessors';
can_ok $o, qw/id name get_id get_name set_id set_name/;
ok $o->id == 2,                           'HRA id read rw accessor';
ok $o->get_id == 2,                       'HRA id getter';
is $o->set_name('Fred'),    'Fred',       'HRA setter';
is $o->name('Flintstone'),  'Flintstone', 'HRA write rw accessor';
is $o->{name},               $o->name,    'HRA internals exposed';

#--------------------------- Object::ClassAccessor ----------------------------
use Object::ClassAccessor;

# using the Class::Accessor built constructor
$o = Object::ClassAccessor->new({ id => 3, name => 'Jake' });
isa_ok $o, 'Object::ClassAccessor';
can_ok $o, qw/name id/;
ok $o->id == 3,                           'CA id read rw accessor';
is $o->name,                'Jake',       'CA name read rw accessor';
is $o->name('Flintstone'),  'Flintstone', 'CA write rw accessor';
is $o->{name},               $o->name,    'CA internals exposed';

#------------------------------- Object::Moose --------------------------------
use Object::Moose;

# using the Moose built constructor
$o = Object::Moose->new(id => 4, name => 'Jake');
isa_ok $o, 'Object::Moose';
can_ok $o, qw/id name/;
ok $o->id == 4,                           'Moose id read rw accessor';
is $o->name('Flintstone'),  'Flintstone', 'Moose write rw accessor';
is $o->{name},               $o->name,    'Moose internals exposed';

#----------------------------- Object::MxDeclare ------------------------------
use Object::MxDeclare;

# using the MooseX::Declare built constructor
$o = Object::MxDeclare->new(id => 5, name => 'Jake');
isa_ok $o, 'Object::MxDeclare';
can_ok $o, qw/id name/;
ok $o->id == 5,                           'MxD id read rw accessor';
is $o->name('Flintstone'),  'Flintstone', 'MxD write rw accessor';
is $o->{name},               $o->name,    'MxD internals exposed';

#----------------------------- Object::InsideOut ------------------------------
use Object::InsideOut;

$o = Object::InsideOut->new(6);
isa_ok $o, 'Object::InsideOut';
can_ok $o, qw/id name get_id get_name set_id set_name/;
ok $o->id == 6,                           'IO id read rw accessor';
is $o->name('Flintstone'),  'Flintstone', 'IO write rw accessor';
ok !exists $o->{name},                    'IO internals inaccessible';

#--------------------------- Object::ClassInsideOut ---------------------------
use Object::InsideOut;

$o = Object::InsideOut->new(7);
isa_ok $o, 'Object::InsideOut';
can_ok $o, qw/id name/;
ok $o->id == 7,                           'CIO id read rw accessor';
is $o->name('Flintstone'),  'Flintstone', 'CIO write rw accessor';
ok !exists $o->{name},                    'CIO internals inaccessible';

#---------------------------- Object::MxInsideOut -----------------------------
use Object::InsideOut;

# using the MooseX::InsideOut built constructor
$o = Object::InsideOut->new(8);
isa_ok $o, 'Object::InsideOut';
can_ok $o, qw/id name/;
ok $o->id == 8,                           'MxIO id read rw accessor';
is $o->name('Flintstone'),  'Flintstone', 'MxIO write rw accessor';
ok !exists $o->{name},                    'MxIO internals inaccessible';

ClassAccessor.pm

package Object::ClassAccessor;
use warnings;
use strict;

use base qw/Class::Accessor/;

__PACKAGE__->mk_accessors(qw/id name/);

# Class::Accessor provides new, but we want to provide defaults for name and id
sub new {
    my $class = shift;

    my $new = $class->SUPER::new(@_);
    $new->{id}   ||= 0;
    $new->{name} ||= '';

    return $new;
}

1;

ClassInsideOut.pm

package Object::ClassInsideOut;
use warnings;
use strict;

use Class::InsideOut qw/public readonly private register/;

# we could have improted Class::InsideOut's id method, bit it would conflict
# with our own id property, so we create an anonymous identity function, here
# based on it
my $identity = sub { Class::InsideOut::id(shift) };

# properties
public   name => my %name;
readonly id   => my %id;

sub new {
    my ($class, $id) = @_;

    my $new = register($class);
    $id{$new->$identity}   = $id || 0;
    $name{$new->$identity} = '';

    return $new;
}

1;

HandRolledAccessors.pm

package Object::HandRolledAccessors;
use warnings;
use strict;

sub new {
    my ($class, $id) = @_;

    # default id to 0
    return bless {
        id   => $id || 0,
        name => '',
    };

    # readers
    sub get_name { shift->{name} }
    sub get_id   { shift->{id}   }

    # writers
    sub set_name { my $self = shift; $self->{name} = shift }
    sub set_id   { my $self = shift; $self->{id}   = shift }

    # read/write accessors
    sub name {
        my $self = shift;

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

    sub id {
        my $self = shift;

        $self->{id} = shift if @_;
        return $self->{id};
    }
}

1;

InsideOut.pm

package Object::InsideOut;
use warnings;
use strict;
use Scalar::Util;

# Hand-rolled insideout objects - properties are only available, outside the
# class, via accessor methods.

# properties
my %name;
my %id;

my $IDENTITY = sub { Scalar::Util::refaddr shift };

sub new {
    my ($class, $id) = @_;

    my $new = bless {}, $class;
    my $ID  = $new->$IDENTITY;

    $id{$ID} = $id || 0;
    $name{$ID} = '';

    return $new;
}

# insideout objects need a destructor
sub DESTROY {
    my $self = shift;

    my $ID = $self->$IDENTITY;
    delete $id{$ID};
    delete $name{$ID};
}

# read accessors
sub get_id   { $id{shift->$IDENTITY}   }
sub get_name { $name{shift->$IDENTITY} }

# write accessors
sub set_id   { my $ID = shift->$IDENTITY; $id{$ID}   = shift }
sub set_name { my $ID = shift->$IDENTITY; $name{$ID} = shift }

# read/write accessors
sub id {
    my $ID = shift->$IDENTITY;

    $id{$ID} = shift if @_;
    return $id{$ID};
}

sub name {
    my $ID = shift->$IDENTITY;

    $name{$ID} = shift if @_;
    return $name{$ID};
}

1;

Moose.pm

package Object::Moose;
use Moose;

# Moose is a feature rich extension to the Perl 5 object system. It provides a
# declarative syntax for defining classes and frees developers from the tedious
# mechanics of writing accessor methods, parameter validation, constructors,
# etc. It is also a metaclass system providing extensive intropsection and the
# ability to modify classes at runtime.
# 
# Moose objects are hash based. Data encapsulation *can* be violated. Privacy
# is by convention, not enforced.

use namespace::autoclean;

has id   => ( isa => 'Int', is => 'ro', default => 0  );
has name => ( isa => 'Str', is => 'rw', default => '' );

__PACKAGE__->meta->make_immutable;

1;

MxDeclare.pm

use MooseX::Declare;

# MooseX::Declare provides an elegant class declaration syntax.  It provides a
# "new" constructor.  "has" sets up appropriate acessors.  MooseX::Declare
# objects are hash based, so you *can* violate encapsulation.  Privacy is by
# convention, not enforced.

class Object::MxDeclare {
    has id   => ( isa => 'Int', is => 'ro', default => 0  );
    has name => ( isa => 'Str', is => 'rw', default => '' );
}

1;

MxInsideOut.pm

package Object::MxInsideOut;
use MooseX::InsideOut;

# MooseX::InsideOut provides enforced encapsulation. Attributes can only be
# accessed via their accessor methods.

use namespace::autoclean;

has id   => ( isa => 'Int', is => 'ro', default => 0  );
has name => ( isa => 'Str', is => 'rw', default => '' );

__PACKAGE__->meta->make_immutable;

1;

Simple.pm

package Object::Simple;
use warnings;
use strict;

# A simple hash based perl class with no frills.  It provides no attribute
# accessors, so the only access to an objects data is through the blessed hash.

sub new {
    my ($class, $id) = @_;

    # default id to 0
    return bless {
        id   => $id || 0,
        name => '',
    };
}

1;