From: Stevan Little Date: Thu, 2 Feb 2006 20:27:38 +0000 (+0000) Subject: Inside out class example, and many other tweaks X-Git-Tag: 0_02~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=52e8a34c12bb2e5d0604c51d2c7223f00fe0357d;p=gitmo%2FClass-MOP.git Inside out class example, and many other tweaks --- diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 5548c7a..440c0ad 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -90,7 +90,7 @@ sub default { \$_[0]->{'$attr_name'} = \$_[1]; }}, 'predicate' => qq{sub { - return defined \$_[0]->{'$attr_name'} ? 1 : 0; + defined \$_[0]->{'$attr_name'} ? 1 : 0; }} ); diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 3832bef..8f048af 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -331,6 +331,57 @@ sub compute_all_applicable_attributes { return @attrs; } +# Class attributes + +sub add_package_variable { + my ($self, $variable, $initial_value) = @_; + (defined $variable && $variable =~ /^[\$\@\%]/) + || confess "variable name does not have a sigil"; + + my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); + if (defined $initial_value) { + no strict 'refs'; + *{$self->name . '::' . $name} = $initial_value; + } + else { + eval $sigil . $self->name . '::' . $name; + confess "Could not create package variable ($variable) because : $@" if $@; + } +} + +sub has_package_variable { + my ($self, $variable) = @_; + (defined $variable && $variable =~ /^[\$\@\%]/) + || confess "variable name does not have a sigil"; + my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); + no strict 'refs'; + defined ${$self->name . '::'}{$name} ? 1 : 0; +} + +sub get_package_variable { + my ($self, $variable) = @_; + (defined $variable && $variable =~ /^[\$\@\%]/) + || confess "variable name does not have a sigil"; + my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); + no strict 'refs'; + # try to fetch it first,.. see what happens + eval '\\' . $sigil . $self->name . '::' . $name; + confess "Could not get the package variable ($variable) because : $@" if $@; + # if we didn't die, then we can return it + # NOTE: + # this is not ideal, better suggestions are welcome + eval '\\' . $sigil . $self->name . '::' . $name; +} + +sub remove_package_variable { + my ($self, $variable) = @_; + (defined $variable && $variable =~ /^[\$\@\%]/) + || confess "variable name does not have a sigil"; + my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); + no strict 'refs'; + delete ${$self->name . '::'}{$name}; +} + 1; __END__ @@ -617,6 +668,39 @@ attribute meta-object. =back +=head2 Package Variables + +Since Perl's classes are built atop the Perl package system, it is +fairly common to use package scoped variables for things like static +class variables. The following methods are convience methods for +the creation and inspection of package scoped variables. + +=over 4 + +=item B + +Given a C<$variable_name>, which must contain a leading sigil, this +method will create that variable within the package which houses the +class. It also takes an optional C<$initial_value>, which must be a +reference of the same type as the sigil of the C<$variable_name> +implies. + +=item B + +This will return a reference to the package variable in +C<$variable_name>. + +=item B + +Returns true (C<1>) if there is a package variable defined for +C<$variable_name>, and false (C<0>) otherwise. + +=item B + +This will attempt to remove the package variable at C<$variable_name>. + +=back + =head1 AUTHOR Stevan Little Estevan@iinteractive.comE diff --git a/t/012_package_variables.t b/t/012_package_variables.t new file mode 100644 index 0000000..4fdb678 --- /dev/null +++ b/t/012_package_variables.t @@ -0,0 +1,120 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 34; +use Test::Exception; + +BEGIN { + use_ok('Class::MOP', ':universal'); +} + +{ + package Foo; +} + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!Foo->meta->has_package_variable('%foo'), '... the meta agrees'); + +lives_ok { + Foo->meta->add_package_variable('%foo' => { one => 1 }); +} '... created %Foo::foo successfully'; + +ok(defined($Foo::{foo}), '... the %foo slot was created successfully'); +ok(Foo->meta->has_package_variable('%foo'), '... the meta agrees'); + +{ + no strict 'refs'; + ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); + is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); +} + +my $foo = Foo->meta->get_package_variable('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +$foo->{two} = 2; + +{ + no strict 'refs'; + is(\%{'Foo::foo'}, Foo->meta->get_package_variable('%foo'), '... our %foo is the same as the metas'); + + ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly'); + is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly'); +} + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +lives_ok { + Foo->meta->add_package_variable('@bar' => [ 1, 2, 3 ]); +} '... created @Foo::bar successfully'; + +ok(defined($Foo::{bar}), '... the @bar slot was created successfully'); + +{ + no strict 'refs'; + is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); + is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); +} + +# now without initial value + +ok(!defined($Foo::{baz}), '... the %baz slot has not been created yet'); + +lives_ok { + Foo->meta->add_package_variable('%baz'); +} '... created %Foo::baz successfully'; + +ok(defined($Foo::{baz}), '... the %baz slot was created successfully'); + +{ + no strict 'refs'; + ${'Foo::baz'}{one} = 1; + + ok(exists ${'Foo::baz'}{one}, '... our %baz was initialized correctly'); + is(${'Foo::baz'}{one}, 1, '... our %baz was initialized correctly'); +} + +ok(!defined($Foo::{bling}), '... the @bling slot has not been created yet'); + +lives_ok { + Foo->meta->add_package_variable('@bling'); +} '... created @Foo::bling successfully'; + +ok(defined($Foo::{bling}), '... the @bling slot was created successfully'); + +{ + no strict 'refs'; + is(scalar @{'Foo::bling'}, 0, '... our @bling was initialized correctly'); + ${'Foo::bling'}[1] = 2; + is(${'Foo::bling'}[1], 2, '... our @bling was assigned too correctly'); +} + +lives_ok { + Foo->meta->remove_package_variable('%foo'); +} '... removed %Foo::foo successfully'; + +ok(!defined($Foo::{foo}), '... the %foo slot was removed successfully'); + +# check some errors + +dies_ok { + Foo->meta->add_package_variable('bar'); +} '... no sigil for bar'; + +dies_ok { + Foo->meta->remove_package_variable('bar'); +} '... no sigil for bar'; + +dies_ok { + Foo->meta->get_package_variable('bar'); +} '... no sigil for bar'; + +dies_ok { + Foo->meta->has_package_variable('bar'); +} '... no sigil for bar'; + + +dies_ok { + Foo->meta->get_package_variable('@.....bar'); +} '... could not fetch variable'; diff --git a/t/102_InsideOutClass_test.t b/t/102_InsideOutClass_test.t new file mode 100644 index 0000000..06a4c4e --- /dev/null +++ b/t/102_InsideOutClass_test.t @@ -0,0 +1,69 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More no_plan => 2; + +BEGIN { + use_ok('Class::MOP'); + use_ok('t::lib::InsideOutClass'); +} + +{ + package Foo; + + sub meta { InsideOutClass->initialize($_[0]) } + + Foo->meta->add_attribute( + InsideOutAttribute->new('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + )) + ); + + Foo->meta->add_attribute( + InsideOutAttribute->new('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'FOO is BAR' + )) + ); + + sub new { + my $class = shift; + bless $class->meta->construct_instance() => $class; + } +} + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +can_ok($foo, 'foo'); +can_ok($foo, 'has_foo'); +can_ok($foo, 'get_bar'); +can_ok($foo, 'set_bar'); + +ok(!$foo->has_foo, '... Foo::foo is not defined yet'); +is($foo->foo(), undef, '... Foo::foo is not defined yet'); +is($foo->get_bar(), 'FOO is BAR', '... Foo::bar has been initialized'); + +$foo->foo('This is Foo'); + +ok($foo->has_foo, '... Foo::foo is defined now'); +is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"'); + +$foo->set_bar(42); +is($foo->get_bar(), 42, '... Foo::bar == 42'); + +my $foo2 = Foo->new(); +isa_ok($foo2, 'Foo'); + +ok(!$foo2->has_foo, '... Foo2::foo is not defined yet'); +is($foo2->foo(), undef, '... Foo2::foo is not defined yet'); +is($foo2->get_bar(), 'FOO is BAR', '... Foo2::bar has been initialized'); + +$foo2->set_bar('DONT PANIC'); +is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC'); + +is($foo->get_bar(), 42, '... Foo::bar == 42'); diff --git a/t/lib/InsideOutClass.pm b/t/lib/InsideOutClass.pm new file mode 100644 index 0000000..a73f24b --- /dev/null +++ b/t/lib/InsideOutClass.pm @@ -0,0 +1,111 @@ + +package InsideOutClass; + +use strict; +use warnings; + +use Class::MOP 'meta'; + +use Scalar::Util 'refaddr'; + +our $VERSION = '0.01'; + +__PACKAGE__->meta->superclasses('Class::MOP::Class'); + +sub construct_instance { + my ($class, %params) = @_; + my $instance = \(my $var); + 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}; + # if nothing was in the %params, we can use the + # attribute's default value (if it has one) + $val ||= $attr->default($instance) if $attr->has_default(); + # now add this to the instance structure + $class->get_package_variable('%' . $attr->name)->{ refaddr($instance) } = $val; + } + return $instance; +} + + +package InsideOutAttribute; + +use strict; +use warnings; + +use Carp 'confess'; +use Scalar::Util 'blessed', 'reftype', 'refaddr'; + +use Class::MOP 'meta'; + +our $VERSION = '0.01'; + +__PACKAGE__->meta->superclasses('Class::MOP::Attribute'); + +{ + # this is just a utility routine to + # handle the details of accessors + my $_inspect_accessor = sub { + my ($attr_name, $type, $accessor) = @_; + + my %ACCESSOR_TEMPLATES = ( + 'accessor' => 'sub { + $' . $attr_name . '{ refaddr($_[0]) } = $_[1] if scalar(@_) == 2; + $' . $attr_name . '{ refaddr($_[0]) }; + }', + 'reader' => 'sub { + $' . $attr_name . '{ refaddr($_[0]) }; + }', + 'writer' => 'sub { + $' . $attr_name . '{ refaddr($_[0]) } = $_[1]; + }', + 'predicate' => 'sub { + defined($' . $attr_name . '{ refaddr($_[0]) }) ? 1 : 0; + }' + ); + + if (reftype($accessor) && reftype($accessor) eq 'HASH') { + my ($name, $method) = each %{$accessor}; + return ($name, Class::MOP::Attribute::Accessor->wrap($method)); + } + else { + my $method = eval $ACCESSOR_TEMPLATES{$type}; + confess "Could not create the $type for $attr_name CODE(\n" . $ACCESSOR_TEMPLATES{$type} . "\n) : $@" if $@; + return ($accessor => Class::MOP::Attribute::Accessor->wrap($method)); + } + }; + + sub install_accessors { + my ($self, $class) = @_; + (blessed($class) && $class->isa('Class::MOP::Class')) + || confess "You must pass a Class::MOP::Class instance (or a subclass)"; + + $class->add_package_variable('%' . $self->name); + + $class->add_method( + $_inspect_accessor->($class->name . '::' . $self->name, 'accessor' => $self->accessor()) + ) if $self->has_accessor(); + + $class->add_method( + $_inspect_accessor->($class->name . '::' . $self->name, 'reader' => $self->reader()) + ) if $self->has_reader(); + + $class->add_method( + $_inspect_accessor->($class->name . '::' . $self->name, 'writer' => $self->writer()) + ) if $self->has_writer(); + + $class->add_method( + $_inspect_accessor->($class->name . '::' . $self->name, 'predicate' => $self->predicate()) + ) if $self->has_predicate(); + return; + } + +} + +## &remove_attribute is left as an exercise for the reader :) + +1; \ No newline at end of file