t-failing/200_examples/006_example_Protomoose.t

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