From: Stevan Little Date: Sat, 18 Mar 2006 15:08:58 +0000 (+0000) Subject: adding possible basic trait/role support X-Git-Tag: 0_05~93 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=51c5e0fb61ff9684f65ab91785e8d4f1303761a7;p=gitmo%2FMoose.git adding possible basic trait/role support --- diff --git a/Build.PL b/Build.PL index 4372a3e..8f83fe4 100644 --- a/Build.PL +++ b/Build.PL @@ -17,8 +17,6 @@ my $build = Module::Build->new( build_requires => { 'Test::More' => '0.47', 'Test::Exception' => '0.21', - 'Locale::US' => '0', - 'Regexp::Common' => '0', }, create_makefile_pl => 'traditional', recursive_test_files => 1, diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm new file mode 100644 index 0000000..e227579 --- /dev/null +++ b/lib/Moose/Meta/Role.pm @@ -0,0 +1,149 @@ + +package Moose::Meta::Role; + +use strict; +use warnings; +use metaclass; + +use Carp 'confess'; +use Scalar::Util 'blessed', 'reftype'; +use Sub::Name 'subname'; +use B 'svref_2object'; + +our $VERSION = '0.01'; + +Moose::Meta::Role->meta->add_attribute('$:package' => ( + reader => 'name', + init_arg => ':package', +)); + +Moose::Meta::Role->meta->add_attribute('@:requires' => ( + reader => 'requires', + predicate => 'has_requires', + init_arg => ':requires', + default => sub { [] } +)); + +{ + my %ROLES; + sub initialize { + my ($class, %options) = @_; + my $pkg = $options{':package'}; + $ROLES{$pkg} ||= $class->meta->new_object(%options); + } +} + +sub add_method { + my ($self, $method_name, $method) = @_; + (defined $method_name && $method_name) + || confess "You must define a method name"; + # use reftype here to allow for blessed subs ... + ('CODE' eq (reftype($method) || '')) + || confess "Your code block must be a CODE reference"; + my $full_method_name = ($self->name . '::' . $method_name); + + no strict 'refs'; + no warnings 'redefine'; + *{$full_method_name} = subname $full_method_name => $method; +} + +sub alias_method { + my ($self, $method_name, $method) = @_; + (defined $method_name && $method_name) + || confess "You must define a method name"; + # use reftype here to allow for blessed subs ... + ('CODE' eq (reftype($method) || '')) + || confess "Your code block must be a CODE reference"; + my $full_method_name = ($self->name . '::' . $method_name); + + no strict 'refs'; + no warnings 'redefine'; + *{$full_method_name} = $method; +} + +sub has_method { + my ($self, $method_name) = @_; + (defined $method_name && $method_name) + || confess "You must define a method name"; + + my $sub_name = ($self->name . '::' . $method_name); + + no strict 'refs'; + return 0 if !defined(&{$sub_name}); + my $method = \&{$sub_name}; + return 0 if (svref_2object($method)->GV->STASH->NAME || '') ne $self->name && + (svref_2object($method)->GV->NAME || '') ne '__ANON__'; + return 1; +} + +sub get_method { + my ($self, $method_name) = @_; + (defined $method_name && $method_name) + || confess "You must define a method name"; + + return unless $self->has_method($method_name); + + no strict 'refs'; + return \&{$self->name . '::' . $method_name}; +} + +sub remove_method { + my ($self, $method_name) = @_; + (defined $method_name && $method_name) + || confess "You must define a method name"; + + my $removed_method = $self->get_method($method_name); + + no strict 'refs'; + delete ${$self->name . '::'}{$method_name} + if defined $removed_method; + + return $removed_method; +} + +sub get_method_list { + my $self = shift; + no strict 'refs'; + grep { !/meta/ && $self->has_method($_) } %{$self->name . '::'}; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::Meta::Role - The Moose role metaobject + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=back + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. If you find a bug please either email me, or add the bug +to cpan-RT. + +=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/lib/Moose/Role.pm b/lib/Moose/Role.pm new file mode 100644 index 0000000..4460e72 --- /dev/null +++ b/lib/Moose/Role.pm @@ -0,0 +1,105 @@ + +package Moose::Role; + +use strict; +use warnings; + +use Carp 'confess'; +use Scalar::Util 'blessed'; +use Sub::Name 'subname'; + +our $VERSION = '0.01'; + +use Moose::Meta::Role; +use Moose::Util::TypeConstraints; + +sub import { + shift; + my $pkg = caller(); + + # we should never export to main + return if $pkg eq 'main'; + + Moose::Util::TypeConstraints->import($pkg); + + my $meta; + if ($pkg->can('meta')) { + $meta = $pkg->meta(); + (blessed($meta) && $meta->isa('Moose::Meta::Role')) + || confess "Whoops, not møøsey enough"; + } + else { + $meta = Moose::Meta::Role->initialize(':package' => $pkg); + $meta->add_method('meta' => sub { + # re-initialize so it inherits properly + Moose::Meta::Role->initialize(':package' => $pkg); + }) + } + + # NOTE: + # &alias_method will install the method, but it + # will not name it with + $meta->alias_method('requires' => subname 'Moose::Role::requires' => sub { + push @{$meta->requires} => @_; + }); + + + # make sure they inherit from Moose::Role::Base + { + no strict 'refs'; + @{$meta->name . '::ISA'} = ('Moose::Role::Base'); + } + + # we recommend using these things + # so export them for them + $meta->alias_method('confess' => \&Carp::confess); + $meta->alias_method('blessed' => \&Scalar::Util::blessed); +} + +package Moose::Role::Base; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::Role - The Moose role + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=back + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. If you find a bug please either email me, or add the bug +to cpan-RT. + +=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/004_basic.t b/t/004_basic.t index 5f6f253..a111d6c 100644 --- a/t/004_basic.t +++ b/t/004_basic.t @@ -3,9 +3,18 @@ use strict; use warnings; -use Test::More tests => 64; +use Test::More; + +BEGIN { + eval "use Regexp::Common; use Locale::US;"; + plan skip_all => "Regexp::Common & Locale::US required for this test" if $@; + plan tests => 70; +} + use Test::Exception; +use Scalar::Util 'isweak'; + BEGIN { use_ok('Moose'); } @@ -151,6 +160,7 @@ is($ii->employees->[0]->middle_initial, undef, '... got the right middle initial is($ii->employees->[0]->full_name, 'Jeremy Shao', '... got the right full name'); is($ii->employees->[0]->title, 'President / Senior Consultant', '... got the right title'); is($ii->employees->[0]->company, $ii, '... got the right company'); +ok(isweak($ii->employees->[0]->{company}), '... the company is a weak-ref'); isa_ok($ii->employees->[0]->address, 'Address'); is($ii->employees->[0]->address->city, 'Manhasset', '... got the right city'); @@ -168,6 +178,7 @@ is($ii->employees->[1]->middle_initial, undef, '... got the right middle initial is($ii->employees->[1]->full_name, 'Tommy Lee', '... got the right full name'); is($ii->employees->[1]->title, 'Vice President / Senior Developer', '... got the right title'); is($ii->employees->[1]->company, $ii, '... got the right company'); +ok(isweak($ii->employees->[1]->{company}), '... the company is a weak-ref'); isa_ok($ii->employees->[1]->address, 'Address'); is($ii->employees->[1]->address->city, 'New York', '... got the right city'); @@ -185,6 +196,7 @@ is($ii->employees->[2]->middle_initial, 'C', '... got the right middle initial v is($ii->employees->[2]->full_name, 'Stevan C. Little', '... got the right full name'); is($ii->employees->[2]->title, 'Senior Developer', '... got the right title'); is($ii->employees->[2]->company, $ii, '... got the right company'); +ok(isweak($ii->employees->[2]->{company}), '... the company is a weak-ref'); isa_ok($ii->employees->[2]->address, 'Address'); is($ii->employees->[2]->address->city, 'Madison', '... got the right city'); @@ -202,6 +214,7 @@ is($ii->employees->[3]->middle_initial, undef, '... got the right middle initial is($ii->employees->[3]->full_name, 'Rob Kinyon', '... got the right full name'); is($ii->employees->[3]->title, 'Developer', '... got the right title'); is($ii->employees->[3]->company, $ii, '... got the right company'); +ok(isweak($ii->employees->[3]->{company}), '... the company is a weak-ref'); isa_ok($ii->employees->[3]->address, 'Address'); is($ii->employees->[3]->address->city, 'Marysville', '... got the right city'); @@ -210,6 +223,14 @@ is($ii->employees->[3]->address->state, 'OH', '... got the right state'); ## check some error conditions for the subtypes dies_ok { + Address->new(street => {}), +} '... we die correctly with bad args'; + +dies_ok { + Address->new(city => {}), +} '... we die correctly with bad args'; + +dies_ok { Address->new(state => 'British Columbia'), } '... we die correctly with bad args'; diff --git a/t/040_basic_role.t b/t/040_basic_role.t new file mode 100644 index 0000000..2f949aa --- /dev/null +++ b/t/040_basic_role.t @@ -0,0 +1,38 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 5; + +BEGIN { + use_ok('Moose'); +} + +{ + package Eq; + use strict; + use warnings; + use Moose::Role; + + requires 'equal'; + + sub not_equal { + my ($self, $other) = @_; + !$self->equal($other); + } +} + +isa_ok(Eq->meta, 'Moose::Meta::Role'); +ok(Eq->isa('Moose::Role::Base'), '... Eq is a role'); + +is_deeply( + Eq->meta->requires, + [ 'equal' ], + '... got the right required method'); + +is_deeply( + [ sort Eq->meta->get_method_list ], + [ 'not_equal' ], + '... got the right method list'); +