\$_[0]->{'$attr_name'} = \$_[1];
}},
'predicate' => qq{sub {
- return defined \$_[0]->{'$attr_name'} ? 1 : 0;
+ defined \$_[0]->{'$attr_name'} ? 1 : 0;
}}
);
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__
=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<add_package_variable ($variable_name, ?$initial_value)>
+
+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<get_package_variable ($variable_name)>
+
+This will return a reference to the package variable in
+C<$variable_name>.
+
+=item B<has_package_variable ($variable_name)>
+
+Returns true (C<1>) if there is a package variable defined for
+C<$variable_name>, and false (C<0>) otherwise.
+
+=item B<remove_package_variable ($variable_name)>
+
+This will attempt to remove the package variable at C<$variable_name>.
+
+=back
+
=head1 AUTHOR
Stevan Little E<gt>stevan@iinteractive.comE<lt>
--- /dev/null
+#!/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';
--- /dev/null
+#!/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');
--- /dev/null
+
+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
projects / gitmo/Class-MOP.git / commitdiff