From: Yuval Kogman Date: Sat, 27 Jun 2009 02:38:40 +0000 (-0400) Subject: remove lazy example (superseded by actual functionality) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=42b799d0c0c768790d8ac6e377f5f1affa568e5b;p=gitmo%2FClass-MOP.git remove lazy example (superseded by actual functionality) --- diff --git a/examples/LazyClass.pod b/examples/LazyClass.pod deleted file mode 100644 index 0c87b3a..0000000 --- a/examples/LazyClass.pod +++ /dev/null @@ -1,163 +0,0 @@ - -package # hide the package from PAUSE - LazyClass::Attribute; - -use strict; -use warnings; - -use Carp 'confess'; - -our $VERSION = '0.05'; - -use base 'Class::MOP::Attribute'; - -sub initialize_instance_slot { - my ($self, $meta_instance, $instance, $params) = @_; - - # if the attr has an init_arg, use that, otherwise, - # use the attributes name itself as the init_arg - my $init_arg = $self->init_arg(); - - if ( exists $params->{$init_arg} ) { - my $val = $params->{$init_arg}; - $meta_instance->set_slot_value($instance, $self->name, $val); - } -} - -sub accessor_metaclass { 'LazyClass::Method::Accessor' } - -package # hide the package from PAUSE - LazyClass::Method::Accessor; - -use strict; -use warnings; - -use Carp 'confess'; - -our $VERSION = '0.01'; - -use base 'Class::MOP::Method::Accessor'; - -sub _generate_accessor_method { - my $attr = (shift)->associated_attribute; - - my $attr_name = $attr->name; - my $meta_instance = $attr->associated_class->get_meta_instance; - - sub { - if (scalar(@_) == 2) { - $meta_instance->set_slot_value($_[0], $attr_name, $_[1]); - } - else { - unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) { - my $value = $attr->has_default ? $attr->default($_[0]) : undef; - $meta_instance->set_slot_value($_[0], $attr_name, $value); - } - - $meta_instance->get_slot_value($_[0], $attr_name); - } - }; -} - -sub _generate_reader_method { - my $attr = (shift)->associated_attribute; - - my $attr_name = $attr->name; - my $meta_instance = $attr->associated_class->get_meta_instance; - - sub { - confess "Cannot assign a value to a read-only accessor" if @_ > 1; - - unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) { - my $value = $attr->has_default ? $attr->default($_[0]) : undef; - $meta_instance->set_slot_value($_[0], $attr_name, $value); - } - - $meta_instance->get_slot_value($_[0], $attr_name); - }; -} - -package # hide the package from PAUSE - LazyClass::Instance; - -use strict; -use warnings; - -our $VERSION = '0.01'; - -use base 'Class::MOP::Instance'; - -sub initialize_all_slots {} - -1; - -__END__ - -=pod - -=head1 NAME - -LazyClass - An example metaclass with lazy initialization - -=head1 SYNOPSIS - - package BinaryTree; - - use metaclass ( - ':attribute_metaclass' => 'LazyClass::Attribute', - ':instance_metaclass' => 'LazyClass::Instance', - ); - - BinaryTree->meta->add_attribute('node' => ( - accessor => 'node', - init_arg => ':node' - )); - - BinaryTree->meta->add_attribute('left' => ( - reader => 'left', - default => sub { BinaryTree->new() } - )); - - BinaryTree->meta->add_attribute('right' => ( - reader => 'right', - default => sub { BinaryTree->new() } - )); - - sub new { - my $class = shift; - $class->meta->new_object(@_); - } - - # ... later in code - - my $btree = BinaryTree->new(); - # ... $btree is an empty hash, no keys are initialized yet - -=head1 DESCRIPTION - -This is an example metclass in which all attributes are created -lazily. This means that no entries are made in the instance HASH -until the last possible moment. - -The example above of a binary tree is a good use for such a -metaclass because it allows the class to be space efficient -without complicating the programing of it. This would also be -ideal for a class which has a large amount of attributes, -several of which are optional. - -=head1 AUTHORS - -Stevan Little Estevan@iinteractive.comE - -Yuval Kogman Enothingmuch@woobling.comE - -=head1 COPYRIGHT AND LICENSE - -Copyright 2006-2008 by Infinity Interactive, Inc. - -L - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/t/106_LazyClass_test.t b/t/106_LazyClass_test.t deleted file mode 100644 index 94c50fb..0000000 --- a/t/106_LazyClass_test.t +++ /dev/null @@ -1,80 +0,0 @@ -use strict; -use warnings; - -use Test::More tests => 25; -use File::Spec; - -BEGIN {use Class::MOP; - require_ok(File::Spec->catfile('examples', 'LazyClass.pod')); -} - -{ - package BinaryTree; - - use metaclass ( - 'attribute_metaclass' => 'LazyClass::Attribute', - 'instance_metaclass' => 'LazyClass::Instance', - ); - - BinaryTree->meta->add_attribute('node' => ( - accessor => 'node', - init_arg => 'node' - )); - - BinaryTree->meta->add_attribute('left' => ( - reader => 'left', - default => sub { BinaryTree->new() } - )); - - BinaryTree->meta->add_attribute('right' => ( - reader => 'right', - default => sub { BinaryTree->new() } - )); - - sub new { - my $class = shift; - bless $class->meta->new_object(@_) => $class; - } -} - -my $root = BinaryTree->new('node' => 0); -isa_ok($root, 'BinaryTree'); - -ok(exists($root->{'node'}), '... node attribute has been initialized yet'); -ok(!exists($root->{'left'}), '... left attribute has not been initialized yet'); -ok(!exists($root->{'right'}), '... right attribute has not been initialized yet'); - -isa_ok($root->left, 'BinaryTree'); -isa_ok($root->right, 'BinaryTree'); - -ok(exists($root->{'left'}), '... left attribute has now been initialized'); -ok(exists($root->{'right'}), '... right attribute has now been initialized'); - -ok(!exists($root->left->{'node'}), '... node attribute has not been initialized yet'); -ok(!exists($root->left->{'left'}), '... left attribute has not been initialized yet'); -ok(!exists($root->left->{'right'}), '... right attribute has not been initialized yet'); - -ok(!exists($root->right->{'node'}), '... node attribute has not been initialized yet'); -ok(!exists($root->right->{'left'}), '... left attribute has not been initialized yet'); -ok(!exists($root->right->{'right'}), '... right attribute has not been initialized yet'); - -is($root->left->node(), undef, '... the left node is uninitialized'); - -ok(exists($root->left->{'node'}), '... node attribute has now been initialized'); - -$root->left->node(1); -is($root->left->node(), 1, '... the left node == 1'); - -ok(!exists($root->left->{'left'}), '... left attribute still has not been initialized yet'); -ok(!exists($root->left->{'right'}), '... right attribute still has not been initialized yet'); - -is($root->right->node(), undef, '... the right node is uninitialized'); - -ok(exists($root->right->{'node'}), '... node attribute has now been initialized'); - -$root->right->node(2); -is($root->right->node(), 2, '... the right node == 1'); - -ok(!exists($root->right->{'left'}), '... left attribute still has not been initialized yet'); -ok(!exists($root->right->{'right'}), '... right attribute still has not been initialized yet'); -