t/200_examples/006_example_Protomoose.t

   1 #!/usr/local/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7
   8 =pod
   9
  10 This is an example of making Moose behave
  11 more like a prototype based object system.
  12
  13 Why?
  14
  15 Well cause merlyn asked if it could :)
  16
  17 =cut
  18
  19 ## ------------------------------------------------------------------
  20 ## make some metaclasses
  21
  22 {
  23     package ProtoMoose::Meta::Instance;
  24     use Moose;
  25
  26     BEGIN { extends 'Moose::Meta::Instance' };
  27
  28     # NOTE:
  29     # do not let things be inlined by
  30     # the attribute or accessor generator
  31     sub is_inlinable { 0 }
  32 }
  33
  34 {
  35     package ProtoMoose::Meta::Method::Accessor;
  36     use Moose;
  37
  38     BEGIN { extends 'Moose::Meta::Method::Accessor' };
  39
  40     # customize the accessors to always grab
  41     # the correct instance in the accessors
  42
  43     sub find_instance {
  44         my ($self, $candidate, $accessor_type) = @_;
  45
  46         my $instance = $candidate;
  47         my $attr     = $self->associated_attribute;
  48
  49         # if it is a class calling it ...
  50         unless (blessed($instance)) {
  51             # then grab the class prototype
  52             $instance = $attr->associated_class->prototype_instance;
  53         }
  54         # if its an instance ...
  55         else {
  56             # and there is no value currently
  57             # associated with the instance and
  58             # we are trying to read it, then ...
  59             if ($accessor_type eq 'r' && !defined($attr->get_value($instance))) {
  60                 # again, defer the prototype in
  61                 # the class in which is was defined
  62                 $instance = $attr->associated_class->prototype_instance;
  63             }
  64             # otherwise, you want to assign
  65             # to your local copy ...
  66         }
  67         return $instance;
  68     }
  69
  70     sub _generate_accessor_method {
  71         my $self = shift;
  72         my $attr = $self->associated_attribute;
  73         return sub {
  74             if (scalar(@_) == 2) {
  75                 $attr->set_value(
  76                     $self->find_instance($_[0], 'w'),
  77                     $_[1]
  78                 );
  79             }
  80             $attr->get_value($self->find_instance($_[0], 'r'));
  81         };
  82     }
  83
  84     sub _generate_reader_method {
  85         my $self = shift;
  86         my $attr = $self->associated_attribute;
  87         return sub {
  88             confess "Cannot assign a value to a read-only accessor" if @_ > 1;
  89             $attr->get_value($self->find_instance($_[0], 'r'));
  90         };
  91     }
  92
  93     sub _generate_writer_method {
  94         my $self = shift;
  95         my $attr = $self->associated_attribute;
  96         return sub {
  97             $attr->set_value(
  98                 $self->find_instance($_[0], 'w'),
  99                 $_[1]
 100             );
 101         };
 102     }
 103
 104     # deal with these later ...
 105     sub generate_predicate_method {}
 106     sub generate_clearer_method {}
 107
 108 }
 109
 110 {
 111     package ProtoMoose::Meta::Attribute;
 112     use Moose;
 113
 114     BEGIN { extends 'Moose::Meta::Attribute' };
 115
 116     sub accessor_metaclass { 'ProtoMoose::Meta::Method::Accessor' }
 117 }
 118
 119 {
 120     package ProtoMoose::Meta::Class;
 121     use Moose;
 122
 123     BEGIN { extends 'Moose::Meta::Class' };
 124
 125     has 'prototype_instance' => (
 126         is        => 'rw',
 127         isa       => 'Object',
 128         predicate => 'has_prototypical_instance',
 129         lazy      => 1,
 130         default   => sub { (shift)->new_object }
 131     );
 132
 133     sub initialize {
 134         # NOTE:
 135         # I am not sure why 'around' does
 136         # not work here, have to investigate
 137         # it later - SL
 138         (shift)->SUPER::initialize(@_,
 139             instance_metaclass  => 'ProtoMoose::Meta::Instance',
 140             attribute_metaclass => 'ProtoMoose::Meta::Attribute',
 141         );
 142     }
 143
 144     around 'construct_instance' => sub {
 145         my $next = shift;
 146         my $self = shift;
 147         # NOTE:
 148         # we actually have to do this here
 149         # to tie-the-knot, if you take it
 150         # out, then you get deep recursion
 151         # several levels deep :)
 152         $self->prototype_instance($next->($self, @_))
 153             unless $self->has_prototypical_instance;
 154         return $self->prototype_instance;
 155     };
 156
 157 }
 158
 159 {
 160     package ProtoMoose::Object;
 161     use metaclass 'ProtoMoose::Meta::Class';
 162     use Moose;
 163
 164     sub new {
 165         my $prototype = blessed($_[0])
 166             ? $_[0]
 167             : $_[0]->meta->prototype_instance;
 168         my (undef, %params) = @_;
 169         my $self = $prototype->meta->clone_object($prototype, %params);
 170         $self->BUILDALL(\%params);
 171         return $self;
 172     }
 173 }
 174
 175 ## ------------------------------------------------------------------
 176 ## make some classes now
 177
 178 {
 179     package Foo;
 180     use Moose;
 181
 182     extends 'ProtoMoose::Object';
 183
 184     has 'bar' => (is => 'rw');
 185 }
 186
 187 {
 188     package Bar;
 189     use Moose;
 190
 191     extends 'Foo';
 192
 193     has 'baz' => (is => 'rw');
 194 }
 195
 196 ## ------------------------------------------------------------------
 197
 198 ## ------------------------------------------------------------------
 199 ## Check that metaclasses are working/inheriting properly
 200
 201 foreach my $class (qw/ProtoMoose::Object Foo Bar/) {
 202     isa_ok($class->meta,
 203     'ProtoMoose::Meta::Class',
 204     '... got the right metaclass for ' . $class . ' ->');
 205
 206     is($class->meta->instance_metaclass,
 207     'ProtoMoose::Meta::Instance',
 208     '... got the right instance meta for ' . $class);
 209
 210     is($class->meta->attribute_metaclass,
 211     'ProtoMoose::Meta::Attribute',
 212     '... got the right attribute meta for ' . $class);
 213 }
 214
 215 ## ------------------------------------------------------------------
 216
 217 # get the prototype for Foo
 218 my $foo_prototype = Foo->meta->prototype_instance;
 219 isa_ok($foo_prototype, 'Foo');
 220
 221 # set a value in the prototype
 222 $foo_prototype->bar(100);
 223 is($foo_prototype->bar, 100, '... got the value stored in the prototype');
 224
 225 # the "class" defers to the
 226 # the prototype when asked
 227 # about attributes
 228 is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)');
 229
 230 # now make an instance, which
 231 # is basically a clone of the
 232 # prototype
 233 my $foo = Foo->new;
 234 isa_ok($foo, 'Foo');
 235
 236 # the instance is *not* the prototype
 237 isnt($foo, $foo_prototype, '... got a new instance of Foo');
 238
 239 # but it has the same values ...
 240 is($foo->bar, 100, '... got the value stored in the instance (inherited from the prototype)');
 241
 242 # we can even change the values
 243 # in the instance
 244 $foo->bar(300);
 245 is($foo->bar, 300, '... got the value stored in the instance (overwriting the one inherited from the prototype)');
 246
 247 # and not change the one in the prototype
 248 is($foo_prototype->bar, 100, '... got the value stored in the prototype');
 249 is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)');
 250
 251 ## subclasses
 252
 253 # now we can check that the subclass
 254 # will seek out the correct prototypical
 255 # value from it's "parent"
 256 is(Bar->bar, 100, '... got the value stored in the Foo prototype (through the Bar class)');
 257
 258 # we can then also set it's local attrs
 259 Bar->baz(50);
 260 is(Bar->baz, 50, '... got the value stored in the prototype (through the Bar class)');
 261
 262 # now we clone the Bar prototype
 263 my $bar = Bar->new;
 264 isa_ok($bar, 'Bar');
 265 isa_ok($bar, 'Foo');
 266
 267 # and we see that we got the right values
 268 # in the instance/clone
 269 is($bar->bar, 100, '... got the value stored in the instance (inherited from the Foo prototype)');
 270 is($bar->baz, 50, '... got the value stored in the instance (inherited from the Bar prototype)');
 271
 272 # nowe we can change the value
 273 $bar->bar(200);
 274 is($bar->bar, 200, '... got the value stored in the instance (overriding the one inherited from the Foo prototype)');
 275
 276 # and all our original and
 277 # prototypical values are still
 278 # the same
 279 is($foo->bar, 300, '... still got the original value stored in the instance (inherited from the prototype)');
 280 is(Foo->bar, 100, '... still got the original value stored in the prototype (through the Foo class)');
 281 is(Bar->bar, 100, '... still got the original value stored in the prototype (through the Bar class)');
 282
 283 done_testing;