From: Stevan Little Date: Sat, 4 Feb 2006 04:48:42 +0000 (+0000) Subject: adding the lazy class example X-Git-Tag: 0_06~15 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4300f56aa63b9e0201ce6d541ee03ac5b6d4ee75;p=gitmo%2FClass-MOP.git adding the lazy class example --- diff --git a/examples/LazyClass.pod b/examples/LazyClass.pod new file mode 100644 index 0000000..e015512 --- /dev/null +++ b/examples/LazyClass.pod @@ -0,0 +1,138 @@ + +package LazyClass; + +use strict; +use warnings; + +use Class::MOP 'meta'; + +our $VERSION = '0.01'; + +use base 'Class::MOP::Class'; + +sub construct_instance { + my ($class, %params) = @_; + my $instance = {}; + foreach my $attr (map { $_->{attribute} } $class->compute_all_applicable_attributes()) { + # if the attr has an init_arg, use that, otherwise, + # use the attributes name itself as the init_arg + my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name; + # try to fetch the init arg from the %params ... + my $val; + $val = $params{$init_arg} if exists $params{$init_arg}; + # now add this to the instance structure + # only if we have found a value at all + $instance->{$attr->name} = $val if defined $val; + } + return $instance; +} + +package LazyClass::Attribute; + +use strict; +use warnings; + +use Class::MOP 'meta'; + +our $VERSION = '0.01'; + +use base 'Class::MOP::Attribute'; + +sub generate_accessor_method { + my ($self, $attr_name) = @_; + sub { + if (scalar(@_) == 2) { + $_[0]->{$attr_name} = $_[1]; + } + else { + if (!exists $_[0]->{$attr_name}) { + my $attr = $self->associated_class->get_attribute($attr_name); + $_[0]->{$attr_name} = $attr->has_default ? $attr->default($_[0]) : undef; + } + $_[0]->{$attr_name}; + } + }; +} + +sub generate_reader_method { + my ($self, $attr_name) = @_; + sub { + if (!exists $_[0]->{$attr_name}) { + my $attr = $self->associated_class->get_attribute($attr_name); + $_[0]->{$attr_name} = $attr->has_default ? $attr->default($_[0]) : undef; + } + $_[0]->{$attr_name}; + }; +} + +1; + +__END__ + +=pod + +=head1 NAME + +LazyClass - An example metaclass with lazy initialization + +=head1 SYNOPSIS + + package BinaryTree; + + sub meta { + LazyClass->initialize($_[0] => ( + ':attribute_metaclass' => 'LazyClass::Attribute' + )); + } + + 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->construct_instance(@_) => $class; + } + + # ... 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 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 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 \ No newline at end of file diff --git a/t/106_LazyClass_test.t b/t/106_LazyClass_test.t new file mode 100644 index 0000000..4b63964 --- /dev/null +++ b/t/106_LazyClass_test.t @@ -0,0 +1,84 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More no_plan => 29; +use File::Spec; + +BEGIN { + use_ok('Class::MOP'); + require_ok(File::Spec->catdir('examples', 'LazyClass.pod')); +} + +{ + package BinaryTree; + + sub meta { + LazyClass->initialize($_[0] => ( + ':attribute_metaclass' => 'LazyClass::Attribute' + )); + } + + 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->construct_instance(@_) => $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'); +