adding possible basic trait/role support

diff --git a/Build.PL b/Build.PL
index 4372a3e..8f83fe4 100644 (file)
--- 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 (file)
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 E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+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 (file)
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 E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+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 (file)
--- 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 (file)
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');    
+