[Moose-commits] r7187 - in
MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes:
lib/MooseX/Emulate/Class/Accessor
lib/MooseX/Emulate/Class/Accessor/Fast
lib/MooseX/Emulate/Class/Accessor/Fast/Meta
lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Role t
t0m at code2.0beta.co.uk
t0m at code2.0beta.co.uk
Mon Dec 29 16:45:18 GMT 2008
Author: t0m
Date: 2008-12-29 08:45:18 -0800 (Mon, 29 Dec 2008)
New Revision: 7187
Added:
MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/lib/MooseX/Emulate/Class/Accessor/Fast/
MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/
MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Accessor.pm
MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Role/
MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Role/Attribute.pm
MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/class_accessor_chained_fast.t
MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/double_apply.t
MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/list_assign.t
MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/reopen_package.t
Modified:
MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/lib/MooseX/Emulate/Class/Accessor/Fast.pm
MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/accessors.t
Log:
Add all my extra tests, and fix some of them
Added: MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Accessor.pm
===================================================================
--- MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Accessor.pm (rev 0)
+++ MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Accessor.pm 2008-12-29 16:45:18 UTC (rev 7187)
@@ -0,0 +1,47 @@
+package MooseX::Emulate::Class::Accessor::Fast::Meta::Accessor;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+
+use base 'Moose::Meta::Method::Accessor';
+
+sub generate_accessor_method {
+ my $attr = (shift)->associated_attribute;
+ return sub {
+ my $self = shift;
+ $attr->set_value($self, $_[0]) if scalar(@_) == 1;
+ $attr->set_value($self, [@_]) if scalar(@_) > 1;
+ $attr->get_value($self);
+ };
+}
+
+sub generate_writer_method {
+ my $attr = (shift)->associated_attribute;
+ return sub {
+ my $self = shift;
+ $attr->set_value($self, $_[0]) if scalar(@_) == 1;
+ $attr->set_value($self, [@_]) if scalar(@_) > 1;
+ };
+}
+
+# FIXME - this is shite, but it does work...
+sub generate_accessor_method_inline {
+ my $attr = (shift)->associated_attribute;
+ my $attr_name = $attr->name;
+ my $meta_instance = $attr->associated_class->instance_metaclass;#
+
+ my $code = eval "sub {
+ my \$self = shift;
+ \$self->{'$attr_name'} = \$_[0] if scalar(\@_) == 1;
+ \$self->{'$attr_name'} = [\@_] if scalar(\@_) > 1;
+ \$self->{'$attr_name'};
+ }";
+ confess "Could not generate inline accessor because : $@" if $@;
+
+ return $code;
+}
+*generate_writer_method_inline = \&generate_accessor_method_inline;
+
+1;
Added: MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Role/Attribute.pm
===================================================================
--- MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Role/Attribute.pm (rev 0)
+++ MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Role/Attribute.pm 2008-12-29 16:45:18 UTC (rev 7187)
@@ -0,0 +1,6 @@
+package MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute;
+use Moose::Role;
+
+sub accessor_metaclass { 'MooseX::Emulate::Class::Accessor::Fast::Meta::Accessor' }
+
+1;
Modified: MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/lib/MooseX/Emulate/Class/Accessor/Fast.pm
===================================================================
--- MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/lib/MooseX/Emulate/Class/Accessor/Fast.pm 2008-12-29 16:39:12 UTC (rev 7186)
+++ MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/lib/MooseX/Emulate/Class/Accessor/Fast.pm 2008-12-29 16:45:18 UTC (rev 7187)
@@ -3,7 +3,10 @@
use Moose::Role;
use Class::MOP ();
use Scalar::Util ();
+use Carp ();
+use MooseX::Emulate::Class::Accessor::Fast::Meta::Accessor ();
+
our $VERSION = '0.00600';
=head1 NAME
@@ -75,6 +78,19 @@
|| Moose::Meta::Class->initialize($class);
};
+my $reopen_package_if_needed = sub {
+ my $self = shift;
+ my $meta = $locate_metaclass->($self);
+ my $immutable = $meta->is_immutable;
+ if ($immutable) {
+ $meta->make_mutable;
+ my $class = Scalar::Util::blessed($self) || $self;
+ Carp::cluck("Class $class was immutable, but needs to be re-opened!");
+ return sub { $meta->make_immutable; };
+ }
+ return sub {};
+};
+
sub BUILD {
my $self = shift;
my %args;
@@ -102,6 +118,7 @@
sub mk_accessors{
my $self = shift;
my $meta = $locate_metaclass->($self);
+ my $reclose = $reopen_package_if_needed->($self);
for my $attr_name (@_){
my $reader = $self->accessor_name_for($attr_name);
my $writer = $self->mutator_name_for( $attr_name);
@@ -109,7 +126,9 @@
#dont overwrite existing methods
if($reader eq $writer){
my %opts = ( $meta->has_method($reader) ? () : (accessor => $reader) );
- my $attr = $meta->add_attribute($attr_name, %opts);
+ my $attr = $meta->find_attribute_by_name($attr_name) || $meta->add_attribute($attr_name, %opts,
+ traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
+ );
if($attr_name eq $reader){
my $alias = "_${attr_name}_accessor";
next if $meta->has_method($alias);
@@ -119,9 +138,12 @@
} else {
my @opts = ( $meta->has_method($writer) ? () : (writer => $writer) );
push(@opts, (reader => $reader)) unless $meta->has_method($reader);
- $meta->add_attribute($attr_name, @opts);
+ my $attr = $meta->find_attribute_by_name($attr_name) || $meta->add_attribute($attr_name, @opts,
+ traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
+ );
}
}
+ $reclose->();
}
=head2 mk_ro_accessors @field_names
@@ -133,15 +155,19 @@
sub mk_ro_accessors{
my $self = shift;
my $meta = $locate_metaclass->($self);
+ my $reclose = $reopen_package_if_needed->($self);
for my $attr_name (@_){
my $reader = $self->accessor_name_for($attr_name);
my @opts = ($meta->has_method($reader) ? () : (reader => $reader) );
- my $attr = $meta->add_attribute($attr_name, @opts);
+ my $attr = $meta->add_attribute($attr_name, @opts,
+ traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
+ ) if scalar(@opts);
if($reader eq $attr_name && $reader eq $self->mutator_name_for($attr_name)){
$meta->add_method("_${attr_name}_accessor" => $attr->get_read_method_ref)
unless $meta->has_method("_${attr_name}_accessor");
}
}
+ $reclose->();
}
=head2 mk_ro_accessors @field_names
@@ -154,15 +180,19 @@
sub mk_wo_accessors{
my $self = shift;
my $meta = $locate_metaclass->($self);
+ my $reclose = $reopen_package_if_needed->($self);
for my $attr_name (@_){
my $writer = $self->mutator_name_for($attr_name);
my @opts = ($meta->has_method($writer) ? () : (writer => $writer) );
- my $attr = $meta->add_attribute($attr_name, @opts);
+ my $attr = $meta->add_attribute($attr_name, @opts,
+ traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
+ ) if scalar(@opts);
if($writer eq $attr_name && $writer eq $self->accessor_name_for($attr_name)){
$meta->add_method("_${attr_name}_accessor" => $attr->get_write_method_ref)
unless $meta->has_method("_${attr_name}_accessor");
}
}
+ $reclose->();
}
=head2 follow_best_practices
@@ -175,11 +205,13 @@
sub follow_best_practice{
my $self = shift;
my $meta = $locate_metaclass->($self);
+ my $reclose = $reopen_package_if_needed->($self);
$meta->remove_method('mutator_name_for');
$meta->remove_method('accessor_name_for');
$meta->add_method('mutator_name_for', sub{ return "set_".$_[1] });
$meta->add_method('accessor_name_for', sub{ return "get_".$_[1] });
+ $reclose->();
}
=head2 mutator_name_for
@@ -208,7 +240,7 @@
confess "No such attribute '$k'"
unless ( my $attr = $meta->find_attribute_by_name($k) );
my $writer = $attr->get_write_method;
- $self->$writer(@_ > 1 ? [@_] : @_);
+ $self->$writer(@_);
}
=head2 get
@@ -236,30 +268,45 @@
sub make_accessor {
my($class, $field) = @_;
my $meta = $locate_metaclass->($class);
- my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field);
+ my $reclose = $reopen_package_if_needed->($class);
+ my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field,
+ traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
+ );
my $reader = $attr->get_read_method_ref;
my $writer = $attr->get_write_method_ref;
- return sub {
+ my $accessor = sub {
my $self = shift;
return $reader->($self) unless @_;
return $writer->($self,(@_ > 1 ? [@_] : @_));
- }
+ };
+ $reclose->();
+ return $accessor;
}
sub make_ro_accessor {
my($class, $field) = @_;
my $meta = $locate_metaclass->($class);
- my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field);
- return $attr->get_read_method_ref;
+ my $reclose = $reopen_package_if_needed->($class);
+ my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field,
+ traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
+ );
+ my $method_ref = $attr->get_read_method_ref;
+ $reclose->();
+ return $method_ref;
}
sub make_wo_accessor {
my($class, $field) = @_;
my $meta = $locate_metaclass->($class);
- my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field);
- return $attr->get_write_method_ref;
+ my $reclose = $reopen_package_if_needed->($class);
+ my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field,
+ traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
+ );
+ my $method_ref = $attr->get_write_method_ref;
+ $reclose->();
+ return $method_ref;
}
1;
Modified: MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/accessors.t
===================================================================
--- MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/accessors.t 2008-12-29 16:39:12 UTC (rev 7186)
+++ MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/accessors.t 2008-12-29 16:45:18 UTC (rev 7187)
@@ -25,6 +25,7 @@
}
);
+ $meta->make_immutable;
$class->mk_accessors(qw( foo bar yar car mar test));
$class->mk_ro_accessors(qw(static unchanged));
$class->mk_wo_accessors(qw(sekret double_sekret));
Added: MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/class_accessor_chained_fast.t
===================================================================
--- MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/class_accessor_chained_fast.t (rev 0)
+++ MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/class_accessor_chained_fast.t 2008-12-29 16:45:18 UTC (rev 7187)
@@ -0,0 +1,34 @@
+use MooseX::Adopt::Class::Accessor::Fast;
+use Test::More tests => 1;
+
+{
+ package Class::Accessor::Chained::Fast;
+ use strict;
+ use base 'Class::Accessor::Fast';
+
+ sub make_accessor {
+ my($class, $field) = @_;
+
+ return sub {
+ my $self = shift;
+ if(@_) {
+ $self->{$field} = (@_ == 1 ? $_[0] : [@_]);
+ return $self;
+ }
+ return $self->{$field};
+ };
+ }
+}
+
+{
+ package TestPackage;
+ use base qw/Class::Accessor::Chained::Fast/;
+ __PACKAGE__->mk_accessors('foo');
+}
+
+my $i = bless {}, 'TestPackage';
+my $other_i = $i->foo('bar');
+TODO: {
+ local $TODO = 'ENOWORKEY';
+ is($other_i, $i, 'Accessor returns instance as opposed to value.');
+}
Added: MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/double_apply.t
===================================================================
--- MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/double_apply.t (rev 0)
+++ MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/double_apply.t 2008-12-29 16:45:18 UTC (rev 7187)
@@ -0,0 +1,30 @@
+#!perl
+use strict;
+use Test::More tests => 5;
+use Test::Exception;
+
+# 1
+use_ok('MooseX::Adopt::Class::Accessor::Fast');
+{
+ package My::Package;
+ use base qw/Class::Accessor::Fast/;
+ for (0..1) {
+ __PACKAGE__->mk_accessors(qw( foo ));
+ __PACKAGE__->mk_ro_accessors(qw( bar ));
+ __PACKAGE__->mk_wo_accessors(qw( baz ));
+ }
+}
+
+my $i = bless { bar => 'bar' }, 'My::Package';
+
+# 2
+lives_ok {
+ $i->foo('foo');
+ $i->baz('baz');
+
+ # 3-5
+ is($i->foo, 'foo');
+ is($i->bar, 'bar');
+ is($i->{baz}, 'baz');
+} 'No exception';
+
Added: MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/list_assign.t
===================================================================
--- MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/list_assign.t (rev 0)
+++ MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/list_assign.t 2008-12-29 16:45:18 UTC (rev 7187)
@@ -0,0 +1,19 @@
+use MooseX::Adopt::Class::Accessor::Fast;
+
+{
+ package Some::Class;
+ use strict;
+ use warnings;
+ use base qw/Class::Accessor::Fast/;
+
+ __PACKAGE__->mk_accessors(qw/ foo /);
+}
+
+package main;
+use strict;
+use Test::More tests => 1;
+my $i = bless {}, 'Some::Class';
+$i->foo(qw/bar baz/);
+is_deeply($i->foo, [qw/ bar baz /]);
+
+
Added: MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/reopen_package.t
===================================================================
--- MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/reopen_package.t (rev 0)
+++ MooseX-Emulate-Class-Accessor-Fast/branches/t0m-extra-tests_and_fixes/t/reopen_package.t 2008-12-29 16:45:18 UTC (rev 7187)
@@ -0,0 +1,32 @@
+use Test::More tests => 9;
+use Test::Exception;
+
+# 1
+BEGIN { require_ok("MooseX::Adopt::Class::Accessor::Fast"); }
+
+use Class::MOP;
+use Class::Accessor::Fast;
+ at My::Class::ISA = 'Class::Accessor::Fast';
+my $meta = Class::MOP::get_metaclass_by_name('My::Class')
+ || Class::MOP::Class->initialize('My::Class');
+$meta->make_immutable;
+
+my @warnings;
+$SIG{__WARN__} = sub { push(@warnings, shift) };
+
+# 2-4
+lives_ok { My::Class->mk_accessors('foo') } 'mk_accessors on immutable';
+lives_ok { My::Class->mk_ro_accessors('quux') } 'mk_ro_accessors on immutable';
+lives_ok { My::Class->mk_wo_accessors('flibble') } 'mk_wo_accessors on immutable';
+
+# 5-7
+lives_ok { My::Class->make_accessor('bar') } 'mk_accessor on immutable';
+lives_ok { My::Class->make_ro_accessor('gong') } 'mk_ro_accessor on immutable';
+lives_ok { My::Class->make_wo_accessor('wibble') } 'mk_wo_accessor on immutable';
+
+# 8
+lives_ok { My::Class->follow_best_practice } 'follow_best_practice on immutable';
+
+# 9
+is( scalar(@warnings), 7, '7 warnings' );
+
More information about the Moose-commits
mailing list