summaryrefslogtreecommitdiff
path: root/t/examples
diff options
context:
space:
mode:
Diffstat (limited to 't/examples')
-rw-r--r--t/examples/Child_Parent_attr_inherit.t136
-rw-r--r--t/examples/example1.t125
-rw-r--r--t/examples/example2.t155
-rw-r--r--t/examples/example_Moose_POOP.t428
-rw-r--r--t/examples/example_Protomoose.t281
-rw-r--r--t/examples/example_w_DCS.t87
-rw-r--r--t/examples/example_w_TestDeep.t71
-rw-r--r--t/examples/record_set_iterator.t114
8 files changed, 1397 insertions, 0 deletions
diff --git a/t/examples/Child_Parent_attr_inherit.t b/t/examples/Child_Parent_attr_inherit.t
new file mode 100644
index 0000000..c84cc25
--- /dev/null
+++ b/t/examples/Child_Parent_attr_inherit.t
@@ -0,0 +1,136 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+=pod
+
+Some examples of triggers and how they can
+be used to manage parent-child relationships.
+
+=cut
+
+{
+
+ package Parent;
+ use Moose;
+
+ has 'last_name' => (
+ is => 'rw',
+ isa => 'Str',
+ trigger => sub {
+ my $self = shift;
+
+ # if the parents last-name changes
+ # then so do all the childrens
+ foreach my $child ( @{ $self->children } ) {
+ $child->last_name( $self->last_name );
+ }
+ }
+ );
+
+ has 'children' =>
+ ( is => 'rw', isa => 'ArrayRef', default => sub { [] } );
+}
+{
+
+ package Child;
+ use Moose;
+
+ has 'parent' => (
+ is => 'rw',
+ isa => 'Parent',
+ required => 1,
+ trigger => sub {
+ my $self = shift;
+
+ # if the parent is changed,..
+ # make sure we update
+ $self->last_name( $self->parent->last_name );
+ }
+ );
+
+ has 'last_name' => (
+ is => 'rw',
+ isa => 'Str',
+ lazy => 1,
+ default => sub { (shift)->parent->last_name }
+ );
+
+}
+
+my $parent = Parent->new( last_name => 'Smith' );
+isa_ok( $parent, 'Parent' );
+
+is( $parent->last_name, 'Smith',
+ '... the parent has the last name we expected' );
+
+$parent->children( [ map { Child->new( parent => $parent ) } ( 0 .. 3 ) ] );
+
+foreach my $child ( @{ $parent->children } ) {
+ is( $child->last_name, $parent->last_name,
+ '... parent and child have the same last name ('
+ . $parent->last_name
+ . ')' );
+}
+
+$parent->last_name('Jones');
+is( $parent->last_name, 'Jones', '... the parent has the new last name' );
+
+foreach my $child ( @{ $parent->children } ) {
+ is( $child->last_name, $parent->last_name,
+ '... parent and child have the same last name ('
+ . $parent->last_name
+ . ')' );
+}
+
+# make a new parent
+
+my $parent2 = Parent->new( last_name => 'Brown' );
+isa_ok( $parent2, 'Parent' );
+
+# orphan the child
+
+my $orphan = pop @{ $parent->children };
+
+# and then the new parent adopts it
+
+$orphan->parent($parent2);
+
+foreach my $child ( @{ $parent->children } ) {
+ is( $child->last_name, $parent->last_name,
+ '... parent and child have the same last name ('
+ . $parent->last_name
+ . ')' );
+}
+
+isnt( $orphan->last_name, $parent->last_name,
+ '... the orphan child does not have the same last name anymore ('
+ . $parent2->last_name
+ . ')' );
+is( $orphan->last_name, $parent2->last_name,
+ '... parent2 and orphan child have the same last name ('
+ . $parent2->last_name
+ . ')' );
+
+# make sure that changes still will not propagate
+
+$parent->last_name('Miller');
+is( $parent->last_name, 'Miller',
+ '... the parent has the new last name (again)' );
+
+foreach my $child ( @{ $parent->children } ) {
+ is( $child->last_name, $parent->last_name,
+ '... parent and child have the same last name ('
+ . $parent->last_name
+ . ')' );
+}
+
+isnt( $orphan->last_name, $parent->last_name,
+ '... the orphan child is not affected by changes in the parent anymore' );
+is( $orphan->last_name, $parent2->last_name,
+ '... parent2 and orphan child have the same last name ('
+ . $parent2->last_name
+ . ')' );
+
+done_testing;
diff --git a/t/examples/example1.t b/t/examples/example1.t
new file mode 100644
index 0000000..643b0cd
--- /dev/null
+++ b/t/examples/example1.t
@@ -0,0 +1,125 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+
+## Roles
+
+{
+ package Constraint;
+ use Moose::Role;
+
+ has 'value' => (isa => 'Num', is => 'ro');
+
+ around 'validate' => sub {
+ my $c = shift;
+ my ($self, $field) = @_;
+ return undef if $c->($self, $self->validation_value($field));
+ return $self->error_message;
+ };
+
+ sub validation_value {
+ my ($self, $field) = @_;
+ return $field;
+ }
+
+ sub error_message { confess "Abstract method!" }
+
+ package Constraint::OnLength;
+ use Moose::Role;
+
+ has 'units' => (isa => 'Str', is => 'ro');
+
+ override 'validation_value' => sub {
+ return length(super());
+ };
+
+ override 'error_message' => sub {
+ my $self = shift;
+ return super() . ' ' . $self->units;
+ };
+
+}
+
+## Classes
+
+{
+ package Constraint::AtLeast;
+ use Moose;
+
+ with 'Constraint';
+
+ sub validate {
+ my ($self, $field) = @_;
+ ($field >= $self->value);
+ }
+
+ sub error_message { 'must be at least ' . (shift)->value; }
+
+ package Constraint::NoMoreThan;
+ use Moose;
+
+ with 'Constraint';
+
+ sub validate {
+ my ($self, $field) = @_;
+ ($field <= $self->value);
+ }
+
+ sub error_message { 'must be no more than ' . (shift)->value; }
+
+ package Constraint::LengthNoMoreThan;
+ use Moose;
+
+ extends 'Constraint::NoMoreThan';
+ with 'Constraint::OnLength';
+
+ package Constraint::LengthAtLeast;
+ use Moose;
+
+ extends 'Constraint::AtLeast';
+ with 'Constraint::OnLength';
+}
+
+my $no_more_than_10 = Constraint::NoMoreThan->new(value => 10);
+isa_ok($no_more_than_10, 'Constraint::NoMoreThan');
+
+ok($no_more_than_10->does('Constraint'), '... Constraint::NoMoreThan does Constraint');
+
+ok(!defined($no_more_than_10->validate(1)), '... validated correctly');
+is($no_more_than_10->validate(11), 'must be no more than 10', '... validation failed correctly');
+
+my $at_least_10 = Constraint::AtLeast->new(value => 10);
+isa_ok($at_least_10, 'Constraint::AtLeast');
+
+ok($at_least_10->does('Constraint'), '... Constraint::AtLeast does Constraint');
+
+ok(!defined($at_least_10->validate(11)), '... validated correctly');
+is($at_least_10->validate(1), 'must be at least 10', '... validation failed correctly');
+
+# onlength
+
+my $no_more_than_10_chars = Constraint::LengthNoMoreThan->new(value => 10, units => 'chars');
+isa_ok($no_more_than_10_chars, 'Constraint::LengthNoMoreThan');
+isa_ok($no_more_than_10_chars, 'Constraint::NoMoreThan');
+
+ok($no_more_than_10_chars->does('Constraint'), '... Constraint::LengthNoMoreThan does Constraint');
+ok($no_more_than_10_chars->does('Constraint::OnLength'), '... Constraint::LengthNoMoreThan does Constraint::OnLength');
+
+ok(!defined($no_more_than_10_chars->validate('foo')), '... validated correctly');
+is($no_more_than_10_chars->validate('foooooooooo'),
+ 'must be no more than 10 chars',
+ '... validation failed correctly');
+
+my $at_least_10_chars = Constraint::LengthAtLeast->new(value => 10, units => 'chars');
+isa_ok($at_least_10_chars, 'Constraint::LengthAtLeast');
+isa_ok($at_least_10_chars, 'Constraint::AtLeast');
+
+ok($at_least_10_chars->does('Constraint'), '... Constraint::LengthAtLeast does Constraint');
+ok($at_least_10_chars->does('Constraint::OnLength'), '... Constraint::LengthAtLeast does Constraint::OnLength');
+
+ok(!defined($at_least_10_chars->validate('barrrrrrrrr')), '... validated correctly');
+is($at_least_10_chars->validate('bar'), 'must be at least 10 chars', '... validation failed correctly');
+
+done_testing;
diff --git a/t/examples/example2.t b/t/examples/example2.t
new file mode 100644
index 0000000..fae26dd
--- /dev/null
+++ b/t/examples/example2.t
@@ -0,0 +1,155 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+sub U {
+ my $f = shift;
+ sub { $f->($f, @_) };
+}
+
+sub Y {
+ my $f = shift;
+ U(sub { my $h = shift; sub { $f->(U($h)->())->(@_) } })->();
+}
+
+{
+ package List;
+ use Moose::Role;
+
+ has '_list' => (
+ is => 'ro',
+ isa => 'ArrayRef',
+ init_arg => '::',
+ default => sub { [] }
+ );
+
+ sub head { (shift)->_list->[0] }
+ sub tail {
+ my $self = shift;
+ (ref $self)->new(
+ '::' => [
+ @{$self->_list}[1 .. $#{$self->_list}]
+ ]
+ );
+ }
+
+ sub print {
+ join ", " => @{$_[0]->_list};
+ }
+
+ package List::Immutable;
+ use Moose::Role;
+
+ requires 'head';
+ requires 'tail';
+
+ sub is_empty { not defined ($_[0]->head) }
+
+ sub length {
+ my $self = shift;
+ (::Y(sub {
+ my $redo = shift;
+ sub {
+ my ($list, $acc) = @_;
+ return $acc if $list->is_empty;
+ $redo->($list->tail, $acc + 1);
+ }
+ }))->($self, 0);
+ }
+
+ sub apply {
+ my ($self, $function) = @_;
+ (::Y(sub {
+ my $redo = shift;
+ sub {
+ my ($list, $func, $acc) = @_;
+ return (ref $list)->new('::' => $acc)
+ if $list->is_empty;
+ $redo->(
+ $list->tail,
+ $func,
+ [ @{$acc}, $func->($list->head) ]
+ );
+ }
+ }))->($self, $function, []);
+ }
+
+ package My::List1;
+ use Moose;
+
+ ::is( ::exception {
+ with 'List', 'List::Immutable';
+ }, undef, '... successfully composed roles together' );
+
+ package My::List2;
+ use Moose;
+
+ ::is( ::exception {
+ with 'List::Immutable', 'List';
+ }, undef, '... successfully composed roles together' );
+
+}
+
+{
+ my $coll = My::List1->new;
+ isa_ok($coll, 'My::List1');
+
+ ok($coll->does('List'), '... $coll does List');
+ ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
+
+ ok($coll->is_empty, '... we have an empty collection');
+ is($coll->length, 0, '... we have a length of 1 for the collection');
+}
+
+{
+ my $coll = My::List2->new;
+ isa_ok($coll, 'My::List2');
+
+ ok($coll->does('List'), '... $coll does List');
+ ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
+
+ ok($coll->is_empty, '... we have an empty collection');
+ is($coll->length, 0, '... we have a length of 1 for the collection');
+}
+
+{
+ my $coll = My::List1->new('::' => [ 1 .. 10 ]);
+ isa_ok($coll, 'My::List1');
+
+ ok($coll->does('List'), '... $coll does List');
+ ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
+
+ ok(!$coll->is_empty, '... we do not have an empty collection');
+ is($coll->length, 10, '... we have a length of 10 for the collection');
+
+ is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value');
+
+ my $coll2 = $coll->apply(sub { $_[0] * $_[0] });
+ isa_ok($coll2, 'My::List1');
+
+ is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same');
+ is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed');
+}
+
+{
+ my $coll = My::List2->new('::' => [ 1 .. 10 ]);
+ isa_ok($coll, 'My::List2');
+
+ ok($coll->does('List'), '... $coll does List');
+ ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
+
+ ok(!$coll->is_empty, '... we do not have an empty collection');
+ is($coll->length, 10, '... we have a length of 10 for the collection');
+
+ is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value');
+
+ my $coll2 = $coll->apply(sub { $_[0] * $_[0] });
+ isa_ok($coll2, 'My::List2');
+
+ is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same');
+ is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed');
+}
+
+done_testing;
diff --git a/t/examples/example_Moose_POOP.t b/t/examples/example_Moose_POOP.t
new file mode 100644
index 0000000..3da6a60
--- /dev/null
+++ b/t/examples/example_Moose_POOP.t
@@ -0,0 +1,428 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+use Test::Requires {
+ 'DBM::Deep' => '1.0003', # skip all if not installed
+ 'DateTime::Format::MySQL' => '0',
+};
+
+use Test::Fatal;
+
+BEGIN {
+ # in case there are leftovers
+ unlink('newswriter.db') if -e 'newswriter.db';
+}
+
+END {
+ unlink('newswriter.db') if -e 'newswriter.db';
+}
+
+
+=pod
+
+This example creates a very basic Object Database which
+links in the instances created with a backend store
+(a DBM::Deep hash). It is by no means to be taken seriously
+as a real-world ODB, but is a proof of concept of the flexibility
+of the ::Instance protocol.
+
+=cut
+
+BEGIN {
+
+ package MooseX::POOP::Meta::Instance;
+ use Moose;
+
+ use DBM::Deep;
+
+ extends 'Moose::Meta::Instance';
+
+ {
+ my %INSTANCE_COUNTERS;
+
+ my $db = DBM::Deep->new({
+ file => "newswriter.db",
+ autobless => 1,
+ locking => 1,
+ });
+
+ sub _reload_db {
+ #use Data::Dumper;
+ #warn Dumper $db;
+ $db = undef;
+ $db = DBM::Deep->new({
+ file => "newswriter.db",
+ autobless => 1,
+ locking => 1,
+ });
+ }
+
+ sub create_instance {
+ my $self = shift;
+ my $class = $self->associated_metaclass->name;
+ my $oid = ++$INSTANCE_COUNTERS{$class};
+
+ $db->{$class}->[($oid - 1)] = {};
+
+ bless {
+ oid => $oid,
+ instance => $db->{$class}->[($oid - 1)]
+ }, $class;
+ }
+
+ sub find_instance {
+ my ($self, $oid) = @_;
+ my $instance = $db->{$self->associated_metaclass->name}->[($oid - 1)];
+
+ bless {
+ oid => $oid,
+ instance => $instance,
+ }, $self->associated_metaclass->name;
+ }
+
+ sub clone_instance {
+ my ($self, $instance) = @_;
+
+ my $class = $self->{meta}->name;
+ my $oid = ++$INSTANCE_COUNTERS{$class};
+
+ my $clone = tied($instance)->clone;
+
+ bless {
+ oid => $oid,
+ instance => $clone,
+ }, $class;
+ }
+ }
+
+ sub get_instance_oid {
+ my ($self, $instance) = @_;
+ $instance->{oid};
+ }
+
+ sub get_slot_value {
+ my ($self, $instance, $slot_name) = @_;
+ return $instance->{instance}->{$slot_name};
+ }
+
+ sub set_slot_value {
+ my ($self, $instance, $slot_name, $value) = @_;
+ $instance->{instance}->{$slot_name} = $value;
+ }
+
+ sub is_slot_initialized {
+ my ($self, $instance, $slot_name, $value) = @_;
+ exists $instance->{instance}->{$slot_name} ? 1 : 0;
+ }
+
+ sub weaken_slot_value {
+ confess "Not sure how well DBM::Deep plays with weak refs, Rob says 'Write a test'";
+ }
+
+ sub inline_slot_access {
+ my ($self, $instance, $slot_name) = @_;
+ sprintf "%s->{instance}->{%s}", $instance, $slot_name;
+ }
+
+ package MooseX::POOP::Meta::Class;
+ use Moose;
+
+ extends 'Moose::Meta::Class';
+
+ override '_construct_instance' => sub {
+ my $class = shift;
+ my $params = @_ == 1 ? $_[0] : {@_};
+ return $class->get_meta_instance->find_instance($params->{oid})
+ if $params->{oid};
+ super();
+ };
+
+}
+{
+ package MooseX::POOP::Object;
+ use metaclass 'MooseX::POOP::Meta::Class' => (
+ instance_metaclass => 'MooseX::POOP::Meta::Instance'
+ );
+ use Moose;
+
+ sub oid {
+ my $self = shift;
+ $self->meta
+ ->get_meta_instance
+ ->get_instance_oid($self);
+ }
+
+}
+{
+ package Newswriter::Author;
+ use Moose;
+
+ extends 'MooseX::POOP::Object';
+
+ has 'first_name' => (is => 'rw', isa => 'Str');
+ has 'last_name' => (is => 'rw', isa => 'Str');
+
+ package Newswriter::Article;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ use DateTime::Format::MySQL;
+
+ extends 'MooseX::POOP::Object';
+
+ subtype 'Headline'
+ => as 'Str'
+ => where { length($_) < 100 };
+
+ subtype 'Summary'
+ => as 'Str'
+ => where { length($_) < 255 };
+
+ subtype 'DateTimeFormatString'
+ => as 'Str'
+ => where { DateTime::Format::MySQL->parse_datetime($_) };
+
+ enum 'Status' => [qw(draft posted pending archive)];
+
+ has 'headline' => (is => 'rw', isa => 'Headline');
+ has 'summary' => (is => 'rw', isa => 'Summary');
+ has 'article' => (is => 'rw', isa => 'Str');
+
+ has 'start_date' => (is => 'rw', isa => 'DateTimeFormatString');
+ has 'end_date' => (is => 'rw', isa => 'DateTimeFormatString');
+
+ has 'author' => (is => 'rw', isa => 'Newswriter::Author');
+
+ has 'status' => (is => 'rw', isa => 'Status');
+
+ around 'start_date', 'end_date' => sub {
+ my $c = shift;
+ my $self = shift;
+ $c->($self, DateTime::Format::MySQL->format_datetime($_[0])) if @_;
+ DateTime::Format::MySQL->parse_datetime($c->($self) || return undef);
+ };
+}
+
+{ # check the meta stuff first
+ isa_ok(MooseX::POOP::Object->meta, 'MooseX::POOP::Meta::Class');
+ isa_ok(MooseX::POOP::Object->meta, 'Moose::Meta::Class');
+ isa_ok(MooseX::POOP::Object->meta, 'Class::MOP::Class');
+
+ is(MooseX::POOP::Object->meta->instance_metaclass,
+ 'MooseX::POOP::Meta::Instance',
+ '... got the right instance metaclass name');
+
+ isa_ok(MooseX::POOP::Object->meta->get_meta_instance, 'MooseX::POOP::Meta::Instance');
+
+ my $base = MooseX::POOP::Object->new;
+ isa_ok($base, 'MooseX::POOP::Object');
+ isa_ok($base, 'Moose::Object');
+
+ isa_ok($base->meta, 'MooseX::POOP::Meta::Class');
+ isa_ok($base->meta, 'Moose::Meta::Class');
+ isa_ok($base->meta, 'Class::MOP::Class');
+
+ is($base->meta->instance_metaclass,
+ 'MooseX::POOP::Meta::Instance',
+ '... got the right instance metaclass name');
+
+ isa_ok($base->meta->get_meta_instance, 'MooseX::POOP::Meta::Instance');
+}
+
+my $article_oid;
+{
+ my $article;
+ is( exception {
+ $article = Newswriter::Article->new(
+ headline => 'Home Office Redecorated',
+ summary => 'The home office was recently redecorated to match the new company colors',
+ article => '...',
+
+ author => Newswriter::Author->new(
+ first_name => 'Truman',
+ last_name => 'Capote'
+ ),
+
+ status => 'pending'
+ );
+ }, undef, '... created my article successfully' );
+ isa_ok($article, 'Newswriter::Article');
+ isa_ok($article, 'MooseX::POOP::Object');
+
+ is( exception {
+ $article->start_date(DateTime->new(year => 2006, month => 6, day => 10));
+ $article->end_date(DateTime->new(year => 2006, month => 6, day => 17));
+ }, undef, '... add the article date-time stuff' );
+
+ ## check some meta stuff
+
+ isa_ok($article->meta, 'MooseX::POOP::Meta::Class');
+ isa_ok($article->meta, 'Moose::Meta::Class');
+ isa_ok($article->meta, 'Class::MOP::Class');
+
+ is($article->meta->instance_metaclass,
+ 'MooseX::POOP::Meta::Instance',
+ '... got the right instance metaclass name');
+
+ isa_ok($article->meta->get_meta_instance, 'MooseX::POOP::Meta::Instance');
+
+ ok($article->oid, '... got a oid for the article');
+
+ $article_oid = $article->oid;
+
+ is($article->headline,
+ 'Home Office Redecorated',
+ '... got the right headline');
+ is($article->summary,
+ 'The home office was recently redecorated to match the new company colors',
+ '... got the right summary');
+ is($article->article, '...', '... got the right article');
+
+ isa_ok($article->start_date, 'DateTime');
+ isa_ok($article->end_date, 'DateTime');
+
+ isa_ok($article->author, 'Newswriter::Author');
+ is($article->author->first_name, 'Truman', '... got the right author first name');
+ is($article->author->last_name, 'Capote', '... got the right author last name');
+
+ is($article->status, 'pending', '... got the right status');
+}
+
+MooseX::POOP::Meta::Instance->_reload_db();
+
+my $article2_oid;
+{
+ my $article2;
+ is( exception {
+ $article2 = Newswriter::Article->new(
+ headline => 'Company wins Lottery',
+ summary => 'An email was received today that informed the company we have won the lottery',
+ article => 'WoW',
+
+ author => Newswriter::Author->new(
+ first_name => 'Katie',
+ last_name => 'Couric'
+ ),
+
+ status => 'posted'
+ );
+ }, undef, '... created my article successfully' );
+ isa_ok($article2, 'Newswriter::Article');
+ isa_ok($article2, 'MooseX::POOP::Object');
+
+ $article2_oid = $article2->oid;
+
+ is($article2->headline,
+ 'Company wins Lottery',
+ '... got the right headline');
+ is($article2->summary,
+ 'An email was received today that informed the company we have won the lottery',
+ '... got the right summary');
+ is($article2->article, 'WoW', '... got the right article');
+
+ ok(!$article2->start_date, '... these two dates are unassigned');
+ ok(!$article2->end_date, '... these two dates are unassigned');
+
+ isa_ok($article2->author, 'Newswriter::Author');
+ is($article2->author->first_name, 'Katie', '... got the right author first name');
+ is($article2->author->last_name, 'Couric', '... got the right author last name');
+
+ is($article2->status, 'posted', '... got the right status');
+
+ ## orig-article
+
+ my $article;
+ is( exception {
+ $article = Newswriter::Article->new(oid => $article_oid);
+ }, undef, '... (re)-created my article successfully' );
+ isa_ok($article, 'Newswriter::Article');
+ isa_ok($article, 'MooseX::POOP::Object');
+
+ is($article->oid, $article_oid, '... got a oid for the article');
+
+ is($article->headline,
+ 'Home Office Redecorated',
+ '... got the right headline');
+ is($article->summary,
+ 'The home office was recently redecorated to match the new company colors',
+ '... got the right summary');
+ is($article->article, '...', '... got the right article');
+
+ isa_ok($article->start_date, 'DateTime');
+ isa_ok($article->end_date, 'DateTime');
+
+ isa_ok($article->author, 'Newswriter::Author');
+ is($article->author->first_name, 'Truman', '... got the right author first name');
+ is($article->author->last_name, 'Capote', '... got the right author last name');
+
+ is( exception {
+ $article->author->first_name('Dan');
+ $article->author->last_name('Rather');
+ }, undef, '... changed the value ok' );
+
+ is($article->author->first_name, 'Dan', '... got the changed author first name');
+ is($article->author->last_name, 'Rather', '... got the changed author last name');
+
+ is($article->status, 'pending', '... got the right status');
+}
+
+MooseX::POOP::Meta::Instance->_reload_db();
+
+{
+ my $article;
+ is( exception {
+ $article = Newswriter::Article->new(oid => $article_oid);
+ }, undef, '... (re)-created my article successfully' );
+ isa_ok($article, 'Newswriter::Article');
+ isa_ok($article, 'MooseX::POOP::Object');
+
+ is($article->oid, $article_oid, '... got a oid for the article');
+
+ is($article->headline,
+ 'Home Office Redecorated',
+ '... got the right headline');
+ is($article->summary,
+ 'The home office was recently redecorated to match the new company colors',
+ '... got the right summary');
+ is($article->article, '...', '... got the right article');
+
+ isa_ok($article->start_date, 'DateTime');
+ isa_ok($article->end_date, 'DateTime');
+
+ isa_ok($article->author, 'Newswriter::Author');
+ is($article->author->first_name, 'Dan', '... got the changed author first name');
+ is($article->author->last_name, 'Rather', '... got the changed author last name');
+
+ is($article->status, 'pending', '... got the right status');
+
+ my $article2;
+ is( exception {
+ $article2 = Newswriter::Article->new(oid => $article2_oid);
+ }, undef, '... (re)-created my article successfully' );
+ isa_ok($article2, 'Newswriter::Article');
+ isa_ok($article2, 'MooseX::POOP::Object');
+
+ is($article2->oid, $article2_oid, '... got a oid for the article');
+
+ is($article2->headline,
+ 'Company wins Lottery',
+ '... got the right headline');
+ is($article2->summary,
+ 'An email was received today that informed the company we have won the lottery',
+ '... got the right summary');
+ is($article2->article, 'WoW', '... got the right article');
+
+ ok(!$article2->start_date, '... these two dates are unassigned');
+ ok(!$article2->end_date, '... these two dates are unassigned');
+
+ isa_ok($article2->author, 'Newswriter::Author');
+ is($article2->author->first_name, 'Katie', '... got the right author first name');
+ is($article2->author->last_name, 'Couric', '... got the right author last name');
+
+ is($article2->status, 'posted', '... got the right status');
+
+}
+
+done_testing;
diff --git a/t/examples/example_Protomoose.t b/t/examples/example_Protomoose.t
new file mode 100644
index 0000000..59beadf
--- /dev/null
+++ b/t/examples/example_Protomoose.t
@@ -0,0 +1,281 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+=pod
+
+This is an example of making Moose behave
+more like a prototype based object system.
+
+Why?
+
+Well cause merlyn asked if it could :)
+
+=cut
+
+## ------------------------------------------------------------------
+## make some metaclasses
+
+{
+ package ProtoMoose::Meta::Instance;
+ use Moose;
+
+ BEGIN { extends 'Moose::Meta::Instance' };
+
+ # NOTE:
+ # do not let things be inlined by
+ # the attribute or accessor generator
+ sub is_inlinable { 0 }
+}
+
+{
+ package ProtoMoose::Meta::Method::Accessor;
+ use Moose;
+
+ BEGIN { extends 'Moose::Meta::Method::Accessor' };
+
+ # customize the accessors to always grab
+ # the correct instance in the accessors
+
+ sub find_instance {
+ my ($self, $candidate, $accessor_type) = @_;
+
+ my $instance = $candidate;
+ my $attr = $self->associated_attribute;
+
+ # if it is a class calling it ...
+ unless (blessed($instance)) {
+ # then grab the class prototype
+ $instance = $attr->associated_class->prototype_instance;
+ }
+ # if its an instance ...
+ else {
+ # and there is no value currently
+ # associated with the instance and
+ # we are trying to read it, then ...
+ if ($accessor_type eq 'r' && !defined($attr->get_value($instance))) {
+ # again, defer the prototype in
+ # the class in which is was defined
+ $instance = $attr->associated_class->prototype_instance;
+ }
+ # otherwise, you want to assign
+ # to your local copy ...
+ }
+ return $instance;
+ }
+
+ sub _generate_accessor_method {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+ return sub {
+ if (scalar(@_) == 2) {
+ $attr->set_value(
+ $self->find_instance($_[0], 'w'),
+ $_[1]
+ );
+ }
+ $attr->get_value($self->find_instance($_[0], 'r'));
+ };
+ }
+
+ sub _generate_reader_method {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+ return sub {
+ confess "Cannot assign a value to a read-only accessor" if @_ > 1;
+ $attr->get_value($self->find_instance($_[0], 'r'));
+ };
+ }
+
+ sub _generate_writer_method {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+ return sub {
+ $attr->set_value(
+ $self->find_instance($_[0], 'w'),
+ $_[1]
+ );
+ };
+ }
+
+ # deal with these later ...
+ sub generate_predicate_method {}
+ sub generate_clearer_method {}
+
+}
+
+{
+ package ProtoMoose::Meta::Attribute;
+ use Moose;
+
+ BEGIN { extends 'Moose::Meta::Attribute' };
+
+ sub accessor_metaclass { 'ProtoMoose::Meta::Method::Accessor' }
+}
+
+{
+ package ProtoMoose::Meta::Class;
+ use Moose;
+
+ BEGIN { extends 'Moose::Meta::Class' };
+
+ has 'prototype_instance' => (
+ is => 'rw',
+ isa => 'Object',
+ predicate => 'has_prototypical_instance',
+ lazy => 1,
+ default => sub { (shift)->new_object }
+ );
+
+ sub initialize {
+ # NOTE:
+ # I am not sure why 'around' does
+ # not work here, have to investigate
+ # it later - SL
+ (shift)->SUPER::initialize(@_,
+ instance_metaclass => 'ProtoMoose::Meta::Instance',
+ attribute_metaclass => 'ProtoMoose::Meta::Attribute',
+ );
+ }
+
+ around '_construct_instance' => sub {
+ my $next = shift;
+ my $self = shift;
+ # NOTE:
+ # we actually have to do this here
+ # to tie-the-knot, if you take it
+ # out, then you get deep recursion
+ # several levels deep :)
+ $self->prototype_instance($next->($self, @_))
+ unless $self->has_prototypical_instance;
+ return $self->prototype_instance;
+ };
+
+}
+
+{
+ package ProtoMoose::Object;
+ use metaclass 'ProtoMoose::Meta::Class';
+ use Moose;
+
+ sub new {
+ my $prototype = blessed($_[0])
+ ? $_[0]
+ : $_[0]->meta->prototype_instance;
+ my (undef, %params) = @_;
+ my $self = $prototype->meta->clone_object($prototype, %params);
+ $self->BUILDALL(\%params);
+ return $self;
+ }
+}
+
+## ------------------------------------------------------------------
+## make some classes now
+
+{
+ package Foo;
+ use Moose;
+
+ extends 'ProtoMoose::Object';
+
+ has 'bar' => (is => 'rw');
+}
+
+{
+ package Bar;
+ use Moose;
+
+ extends 'Foo';
+
+ has 'baz' => (is => 'rw');
+}
+
+## ------------------------------------------------------------------
+
+## ------------------------------------------------------------------
+## Check that metaclasses are working/inheriting properly
+
+foreach my $class (qw/ProtoMoose::Object Foo Bar/) {
+ isa_ok($class->meta,
+ 'ProtoMoose::Meta::Class',
+ '... got the right metaclass for ' . $class . ' ->');
+
+ is($class->meta->instance_metaclass,
+ 'ProtoMoose::Meta::Instance',
+ '... got the right instance meta for ' . $class);
+
+ is($class->meta->attribute_metaclass,
+ 'ProtoMoose::Meta::Attribute',
+ '... got the right attribute meta for ' . $class);
+}
+
+## ------------------------------------------------------------------
+
+# get the prototype for Foo
+my $foo_prototype = Foo->meta->prototype_instance;
+isa_ok($foo_prototype, 'Foo');
+
+# set a value in the prototype
+$foo_prototype->bar(100);
+is($foo_prototype->bar, 100, '... got the value stored in the prototype');
+
+# the "class" defers to the
+# the prototype when asked
+# about attributes
+is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)');
+
+# now make an instance, which
+# is basically a clone of the
+# prototype
+my $foo = Foo->new;
+isa_ok($foo, 'Foo');
+
+# the instance is *not* the prototype
+isnt($foo, $foo_prototype, '... got a new instance of Foo');
+
+# but it has the same values ...
+is($foo->bar, 100, '... got the value stored in the instance (inherited from the prototype)');
+
+# we can even change the values
+# in the instance
+$foo->bar(300);
+is($foo->bar, 300, '... got the value stored in the instance (overwriting the one inherited from the prototype)');
+
+# and not change the one in the prototype
+is($foo_prototype->bar, 100, '... got the value stored in the prototype');
+is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)');
+
+## subclasses
+
+# now we can check that the subclass
+# will seek out the correct prototypical
+# value from its "parent"
+is(Bar->bar, 100, '... got the value stored in the Foo prototype (through the Bar class)');
+
+# we can then also set its local attrs
+Bar->baz(50);
+is(Bar->baz, 50, '... got the value stored in the prototype (through the Bar class)');
+
+# now we clone the Bar prototype
+my $bar = Bar->new;
+isa_ok($bar, 'Bar');
+isa_ok($bar, 'Foo');
+
+# and we see that we got the right values
+# in the instance/clone
+is($bar->bar, 100, '... got the value stored in the instance (inherited from the Foo prototype)');
+is($bar->baz, 50, '... got the value stored in the instance (inherited from the Bar prototype)');
+
+# nowe we can change the value
+$bar->bar(200);
+is($bar->bar, 200, '... got the value stored in the instance (overriding the one inherited from the Foo prototype)');
+
+# and all our original and
+# prototypical values are still
+# the same
+is($foo->bar, 300, '... still got the original value stored in the instance (inherited from the prototype)');
+is(Foo->bar, 100, '... still got the original value stored in the prototype (through the Foo class)');
+is(Bar->bar, 100, '... still got the original value stored in the prototype (through the Bar class)');
+
+done_testing;
diff --git a/t/examples/example_w_DCS.t b/t/examples/example_w_DCS.t
new file mode 100644
index 0000000..eb78d8d
--- /dev/null
+++ b/t/examples/example_w_DCS.t
@@ -0,0 +1,87 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+=pod
+
+This tests how well Moose type constraints
+play with Declare::Constraints::Simple.
+
+Pretty well if I do say so myself :)
+
+=cut
+
+use Test::Requires 'Declare::Constraints::Simple'; # skip all if not installed
+use Test::Fatal;
+
+{
+ package Foo;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+ use Declare::Constraints::Simple -All;
+
+ # define your own type ...
+ type( 'HashOfArrayOfObjects',
+ {
+ where => IsHashRef(
+ -keys => HasLength,
+ -values => IsArrayRef(IsObject)
+ )
+ } );
+
+ has 'bar' => (
+ is => 'rw',
+ isa => 'HashOfArrayOfObjects',
+ );
+
+ # inline the constraints as anon-subtypes
+ has 'baz' => (
+ is => 'rw',
+ isa => subtype( { as => 'ArrayRef', where => IsArrayRef(IsInt) } ),
+ );
+
+ package Bar;
+ use Moose;
+}
+
+my $hash_of_arrays_of_objs = {
+ foo1 => [ Bar->new ],
+ foo2 => [ Bar->new, Bar->new ],
+};
+
+my $array_of_ints = [ 1 .. 10 ];
+
+my $foo;
+is( exception {
+ $foo = Foo->new(
+ 'bar' => $hash_of_arrays_of_objs,
+ 'baz' => $array_of_ints,
+ );
+}, undef, '... construction succeeded' );
+isa_ok($foo, 'Foo');
+
+is_deeply($foo->bar, $hash_of_arrays_of_objs, '... got our value correctly');
+is_deeply($foo->baz, $array_of_ints, '... got our value correctly');
+
+isnt( exception {
+ $foo->bar([]);
+}, undef, '... validation failed correctly' );
+
+isnt( exception {
+ $foo->bar({ foo => 3 });
+}, undef, '... validation failed correctly' );
+
+isnt( exception {
+ $foo->bar({ foo => [ 1, 2, 3 ] });
+}, undef, '... validation failed correctly' );
+
+isnt( exception {
+ $foo->baz([ "foo" ]);
+}, undef, '... validation failed correctly' );
+
+isnt( exception {
+ $foo->baz({});
+}, undef, '... validation failed correctly' );
+
+done_testing;
diff --git a/t/examples/example_w_TestDeep.t b/t/examples/example_w_TestDeep.t
new file mode 100644
index 0000000..caac9c6
--- /dev/null
+++ b/t/examples/example_w_TestDeep.t
@@ -0,0 +1,71 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+=pod
+
+This tests how well Moose type constraints
+play with Test::Deep.
+
+Its not as pretty as Declare::Constraints::Simple,
+but it is not completely horrid either.
+
+=cut
+
+use Test::Requires 'Test::Deep'; # skip all if not installed
+use Test::Fatal;
+
+{
+ package Foo;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ use Test::Deep qw[
+ eq_deeply array_each subhashof ignore
+ ];
+
+ # define your own type ...
+ type 'ArrayOfHashOfBarsAndRandomNumbers'
+ => where {
+ eq_deeply($_,
+ array_each(
+ subhashof({
+ bar => Test::Deep::isa('Bar'),
+ random_number => ignore()
+ })
+ )
+ )
+ };
+
+ has 'bar' => (
+ is => 'rw',
+ isa => 'ArrayOfHashOfBarsAndRandomNumbers',
+ );
+
+ package Bar;
+ use Moose;
+}
+
+my $array_of_hashes = [
+ { bar => Bar->new, random_number => 10 },
+ { bar => Bar->new },
+];
+
+my $foo;
+is( exception {
+ $foo = Foo->new('bar' => $array_of_hashes);
+}, undef, '... construction succeeded' );
+isa_ok($foo, 'Foo');
+
+is_deeply($foo->bar, $array_of_hashes, '... got our value correctly');
+
+isnt( exception {
+ $foo->bar({});
+}, undef, '... validation failed correctly' );
+
+isnt( exception {
+ $foo->bar([{ foo => 3 }]);
+}, undef, '... validation failed correctly' );
+
+done_testing;
diff --git a/t/examples/record_set_iterator.t b/t/examples/record_set_iterator.t
new file mode 100644
index 0000000..fe432b4
--- /dev/null
+++ b/t/examples/record_set_iterator.t
@@ -0,0 +1,114 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+
+{
+ package Record;
+ use Moose;
+
+ has 'first_name' => (is => 'ro', isa => 'Str');
+ has 'last_name' => (is => 'ro', isa => 'Str');
+
+ package RecordSet;
+ use Moose;
+
+ has 'data' => (
+ is => 'ro',
+ isa => 'ArrayRef[Record]',
+ default => sub { [] },
+ );
+
+ has 'index' => (
+ is => 'rw',
+ isa => 'Int',
+ default => sub { 0 },
+ );
+
+ sub next {
+ my $self = shift;
+ my $i = $self->index;
+ $self->index($i + 1);
+ return $self->data->[$i];
+ }
+
+ package RecordSetIterator;
+ use Moose;
+
+ has 'record_set' => (
+ is => 'rw',
+ isa => 'RecordSet',
+ );
+
+ # list the fields you want to
+ # fetch from the current record
+ my @fields = Record->meta->get_attribute_list;
+
+ has 'current_record' => (
+ is => 'rw',
+ isa => 'Record',
+ lazy => 1,
+ default => sub {
+ my $self = shift;
+ $self->record_set->next() # grab the first one
+ },
+ trigger => sub {
+ my $self = shift;
+ # whenever this attribute is
+ # updated, it will clear all
+ # the fields for you.
+ $self->$_() for map { '_clear_' . $_ } @fields;
+ }
+ );
+
+ # define the attributes
+ # for all the fields.
+ for my $field (@fields) {
+ has $field => (
+ is => 'ro',
+ isa => 'Any',
+ lazy => 1,
+ default => sub {
+ my $self = shift;
+ # fetch the value from
+ # the current record
+ $self->current_record->$field();
+ },
+ # make sure they have a clearer ..
+ clearer => ('_clear_' . $field)
+ );
+ }
+
+ sub get_next_record {
+ my $self = shift;
+ $self->current_record($self->record_set->next());
+ }
+}
+
+my $rs = RecordSet->new(
+ data => [
+ Record->new(first_name => 'Bill', last_name => 'Smith'),
+ Record->new(first_name => 'Bob', last_name => 'Jones'),
+ Record->new(first_name => 'Jim', last_name => 'Johnson'),
+ ]
+);
+isa_ok($rs, 'RecordSet');
+
+my $rsi = RecordSetIterator->new(record_set => $rs);
+isa_ok($rsi, 'RecordSetIterator');
+
+is($rsi->first_name, 'Bill', '... got the right first name');
+is($rsi->last_name, 'Smith', '... got the right last name');
+
+$rsi->get_next_record;
+
+is($rsi->first_name, 'Bob', '... got the right first name');
+is($rsi->last_name, 'Jones', '... got the right last name');
+
+$rsi->get_next_record;
+
+is($rsi->first_name, 'Jim', '... got the right first name');
+is($rsi->last_name, 'Johnson', '... got the right last name');
+
+done_testing;
View Lorry Controller Status