From: Stevan Little <stevan.little@iinteractive.com>
Date: Sat, 18 Mar 2006 05:42:16 +0000 (+0000)
Subject: MOOOOOOOOOOOOOOSE
X-Git-Tag: 0_05~95
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5569c072bdd927aa987d9bb1234ae69947db4867;p=gitmo%2FMoose.git

MOOOOOOOOOOOOOOSE
---

diff --git a/Build.PL b/Build.PL
index d9c09bb..9bc5aed 100644
--- a/Build.PL
+++ b/Build.PL
@@ -16,6 +16,8 @@ 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.pm b/lib/Moose.pm
index 01564eb..67434ea 100644
--- a/lib/Moose.pm
+++ b/lib/Moose.pm
@@ -1,4 +1,6 @@
 
+use lib '/Users/stevan/Projects/CPAN/Class-MOP/Class-MOP/lib';
+
 package Moose;
 
 use strict;
@@ -30,7 +32,7 @@ sub import {
 	return if $pkg eq 'main';
 	
 	Moose::Util::TypeConstraints->import($pkg);
-	
+
 	my $meta;
 	if ($pkg->can('meta')) {
 		$meta = $pkg->meta();
@@ -96,15 +98,15 @@ sub import {
 		my $code = pop @_;
 		$meta->add_around_method_modifier($_, $code) for @_;	
 	});	
-	
+
 	# make sure they inherit from Moose::Object
-	$meta->superclasses('Moose::Object') 
-		unless $meta->superclasses();
+	$meta->superclasses('Moose::Object')
+       unless $meta->superclasses();
 
 	# we recommend using these things 
 	# so export them for them
-	$meta->alias_method('confess' => \&confess);			
-	$meta->alias_method('blessed' => \&blessed);				
+	$meta->alias_method('confess' => \&Carp::confess);			
+	$meta->alias_method('blessed' => \&Scalar::Util::blessed);				
 }
 
 1;
@@ -175,26 +177,40 @@ more :)
 
 =over 4
 
-=item Makes Other Object Systems Envious
+=item Make Other Object Systems Envious
 
 =item Makes Object Orientation So Easy
 
-=item Makes Object Orientation Sound Easy
+=item Makes Object Orientation Spiffy- Er  (sorry ingy)
 
-=item Makes Object Orientation Spiffy- Er
+=item Most Other Object Systems Emasculate
 
 =item My Overcraft Overfilled (with) Some Eels
 
 =item Moose Often Ovulate Sorta Early
 
-=item Most Other Object Systems Emasculate
-
 =item Many Overloaded Object Systems Exists 
 
 =item Moose Offers Often Super Extensions
 
 =back
 
+=head1 ACKNOWLEDGEMENTS
+
+=over 4
+
+=item I blame Sam Vilain for giving me my first hit of meta-model crack.
+
+=item I blame Audrey Tang for encouraging that meta-crack habit in #perl6.
+
+=item Without the love and encouragement of Yuval "nothingmuch" Kogman, 
+this module would not be possible (and it wouldn't have a name).
+
+=item The basis of the TypeContraints module was Rob Kinyon's idea 
+originally, I just ran with it.
+
+=back
+
 =head1 BUGS
 
 All complex software has bugs lurking in it, and this module is no 
diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index 2d59ce1..5c4af2f 100644
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -9,7 +9,7 @@ use Carp         'confess';
 
 use Moose::Util::TypeConstraints ':no_export';
 
-our $VERSION = '0.01';
+our $VERSION = '0.02';
 
 use base 'Class::MOP::Attribute';
 
@@ -43,7 +43,7 @@ sub generate_accessor_method {
 		    return sub {
 				if (scalar(@_) == 2) {
 					(defined $self->type_constraint->($_[1]))
-						|| confess "Attribute ($attr_name) does not pass the type contraint"
+						|| confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
 							if defined $_[1];
 			        $_[0]->{$attr_name} = $_[1];
 					weaken($_[0]->{$attr_name});
@@ -55,7 +55,7 @@ sub generate_accessor_method {
 		    return sub {
 				if (scalar(@_) == 2) {
 					(defined $self->type_constraint->($_[1]))
-						|| confess "Attribute ($attr_name) does not pass the type contraint"
+						|| confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
 							if defined $_[1];
 			        $_[0]->{$attr_name} = $_[1];
 				}
@@ -88,7 +88,7 @@ sub generate_writer_method {
 		if ($self->has_weak_ref) {
 		    return sub { 
 				(defined $self->type_constraint->($_[1]))
-					|| confess "Attribute ($attr_name) does not pass the type contraint"
+					|| confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
 						if defined $_[1];
 				$_[0]->{$attr_name} = $_[1];
 				weaken($_[0]->{$attr_name});
@@ -97,7 +97,7 @@ sub generate_writer_method {
 		else {
 		    return sub { 
 				(defined $self->type_constraint->($_[1]))
-					|| confess "Attribute ($attr_name) does not pass the type contraint"
+					|| confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
 						if defined $_[1];
 				$_[0]->{$attr_name} = $_[1];
 			};			
diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index 361c95a..e29786f 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -22,8 +22,8 @@ sub construct_instance {
         # attribute's default value (if it has one)
         $val ||= $attr->default($instance) if $attr->has_default; 
 		if (defined $val && $attr->has_type_constraint) {
-			(defined $attr->type_constraint->($val))
-				|| confess "Attribute (" . $attr->name . ") does not pass the type contraint";			
+            (defined($attr->type_constraint->($val))) 
+                || confess "Attribute () does not pass the type contraint with";			
 		}
         $instance->{$attr->name} = $val;
     }
diff --git a/lib/Moose/Object.pm b/lib/Moose/Object.pm
index 68db685..cf08065 100644
--- a/lib/Moose/Object.pm
+++ b/lib/Moose/Object.pm
@@ -22,14 +22,14 @@ sub new {
 sub BUILDALL {
 	my ($self, %params) = @_;
 	foreach my $method ($self->meta->find_all_methods_by_name('BUILD')) {
-		$method->{method}->($self, %params);
+		$method->{code}->($self, %params);
 	}
 }
 
 sub DEMOLISHALL {
 	my $self = shift;
 	foreach my $method ($self->meta->find_all_methods_by_name('DEMOLISH')) {
-		$method->{method}->($self);
+		$method->{code}->($self);
 	}	
 }
 
diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index a9a6b52..6c65523 100644
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -7,7 +7,7 @@ use warnings;
 use Sub::Name    'subname';
 use Scalar::Util 'blessed';
 
-our $VERSION = '0.01';
+our $VERSION = '0.02';
 
 sub import {
 	shift;
@@ -66,12 +66,12 @@ sub subtype ($$;$) {
 	else {
 		($parent, $check) = ($name, $parent);
 		$parent = $TYPES{$parent} unless $parent && ref($parent) eq 'CODE';		
-		return subname((caller() . '::__anon_subtype__') => sub { 
+		return subname '__anon_subtype__' => sub { 
 			return $TYPES{$name} unless defined $_[0];			
 			local $_ = $_[0];
 			return undef unless defined $parent->($_[0]) && $check->($_[0]);
 			$_[0];
-		});		
+		};		
 	}
 }
 
diff --git a/t/004_basic.t b/t/004_basic.t
new file mode 100644
index 0000000..5f6f253
--- /dev/null
+++ b/t/004_basic.t
@@ -0,0 +1,235 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 64;
+use Test::Exception;
+
+BEGIN {
+    use_ok('Moose');           
+}
+
+{
+    package Address;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    use Locale::US;
+    use Regexp::Common 'zip';
+    
+    my $STATES = Locale::US->new;
+    
+    subtype USState 
+        => as Str
+        => where {
+            (exists $STATES->{code2state}{uc($_)} || exists $STATES->{state2code}{uc($_)})
+        };
+        
+    subtype USZipCode 
+        => as Value
+        => where {
+            /^$RE{zip}{US}{-extended => 'allow'}$/            
+        };
+    
+    has 'street'   => (is => 'rw', isa => Str());
+    has 'city'     => (is => 'rw', isa => Str());
+    has 'state'    => (is => 'rw', isa => USState());
+    has 'zip_code' => (is => 'rw', isa => USZipCode());   
+    
+    package Company;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    has 'name'      => (is => 'rw', isa => Str());
+    has 'address'   => (is => 'rw', isa => 'Address'); 
+    has 'employees' => (is => 'rw', isa => subtype ArrayRef => where { 
+        ($_->isa('Employee') || return) for @$_; 1 
+    });    
+    
+    sub BUILD {
+        my ($self, %params) = @_;
+        if ($params{employees}) {
+            foreach my $employee (@{$params{employees}}) {
+                $employee->company($self);
+            }
+        }
+    }
+    
+    sub get_employee_count { scalar @{(shift)->employees} }
+    
+    package Person;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    has 'first_name'     => (is => 'rw', isa => Str());
+    has 'last_name'      => (is => 'rw', isa => Str());       
+    has 'middle_initial' => (is => 'rw', isa => Str(), predicate => 'has_middle_initial');  
+    has 'address'        => (is => 'rw', isa => 'Address');
+    
+    sub full_name {
+        my $self = shift;
+        return $self->first_name . 
+              ($self->has_middle_initial ? ' ' . $self->middle_initial . '. ' : ' ') .
+               $self->last_name;
+    }
+      
+    package Employee;
+    use strict;
+    use warnings;
+    use Moose;  
+    
+    extends 'Person';
+    
+    has 'title'   => (is => 'rw', isa => Str());
+    has 'company' => (is => 'rw', isa => 'Company', weak_ref => 1);  
+}
+
+my $ii;
+lives_ok {
+    $ii = Company->new(
+        name    => 'Infinity Interactive',
+        address => Address->new(
+            street   => '565 Plandome Rd., Suite 307',
+            city     => 'Manhasset',
+            state    => 'NY',
+            zip_code => '11030'
+        ),
+        employees => [
+            Employee->new(
+                first_name     => 'Jeremy',
+                last_name      => 'Shao',
+                title          => 'President / Senior Consultant',
+                address        => Address->new(city => 'Manhasset', state => 'NY')
+            ),
+            Employee->new(
+                first_name     => 'Tommy',
+                last_name      => 'Lee',
+                title          => 'Vice President / Senior Developer',
+                address        => Address->new(city => 'New York', state => 'NY')
+            ),        
+            Employee->new(
+                first_name     => 'Stevan',
+                middle_initial => 'C',
+                last_name      => 'Little',
+                title          => 'Senior Developer',            
+                address        => Address->new(city => 'Madison', state => 'CT')
+            ),
+            Employee->new(
+                first_name     => 'Rob',
+                last_name      => 'Kinyon',
+                title          => 'Developer',            
+                address        => Address->new(city => 'Marysville', state => 'OH')
+            ),        
+        ]
+    );
+} '... created the entire company successfully';
+isa_ok($ii, 'Company');
+
+is($ii->name, 'Infinity Interactive', '... got the right name for the company');
+
+isa_ok($ii->address, 'Address');
+is($ii->address->street, '565 Plandome Rd., Suite 307', '... got the right street address');
+is($ii->address->city, 'Manhasset', '... got the right city');
+is($ii->address->state, 'NY', '... got the right state');
+is($ii->address->zip_code, 11030, '... got the zip code');
+
+is($ii->get_employee_count, 4, '... got the right employee count');
+
+# employee #1
+
+isa_ok($ii->employees->[0], 'Employee');
+isa_ok($ii->employees->[0], 'Person');
+
+is($ii->employees->[0]->first_name, 'Jeremy', '... got the right first name');
+is($ii->employees->[0]->last_name, 'Shao', '... got the right last name');
+ok(!$ii->employees->[0]->has_middle_initial, '... no middle initial');
+is($ii->employees->[0]->middle_initial, undef, '... got the right middle initial value');
+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');
+
+isa_ok($ii->employees->[0]->address, 'Address');
+is($ii->employees->[0]->address->city, 'Manhasset', '... got the right city');
+is($ii->employees->[0]->address->state, 'NY', '... got the right state');
+
+# employee #2
+
+isa_ok($ii->employees->[1], 'Employee');
+isa_ok($ii->employees->[1], 'Person');
+
+is($ii->employees->[1]->first_name, 'Tommy', '... got the right first name');
+is($ii->employees->[1]->last_name, 'Lee', '... got the right last name');
+ok(!$ii->employees->[1]->has_middle_initial, '... no middle initial');
+is($ii->employees->[1]->middle_initial, undef, '... got the right middle initial value');
+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');
+
+isa_ok($ii->employees->[1]->address, 'Address');
+is($ii->employees->[1]->address->city, 'New York', '... got the right city');
+is($ii->employees->[1]->address->state, 'NY', '... got the right state');
+
+# employee #3
+
+isa_ok($ii->employees->[2], 'Employee');
+isa_ok($ii->employees->[2], 'Person');
+
+is($ii->employees->[2]->first_name, 'Stevan', '... got the right first name');
+is($ii->employees->[2]->last_name, 'Little', '... got the right last name');
+ok($ii->employees->[2]->has_middle_initial, '... got middle initial');
+is($ii->employees->[2]->middle_initial, 'C', '... got the right middle initial value');
+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');
+
+isa_ok($ii->employees->[2]->address, 'Address');
+is($ii->employees->[2]->address->city, 'Madison', '... got the right city');
+is($ii->employees->[2]->address->state, 'CT', '... got the right state');
+
+# employee #4
+
+isa_ok($ii->employees->[3], 'Employee');
+isa_ok($ii->employees->[3], 'Person');
+
+is($ii->employees->[3]->first_name, 'Rob', '... got the right first name');
+is($ii->employees->[3]->last_name, 'Kinyon', '... got the right last name');
+ok(!$ii->employees->[3]->has_middle_initial, '... got middle initial');
+is($ii->employees->[3]->middle_initial, undef, '... got the right middle initial value');
+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');
+
+isa_ok($ii->employees->[3]->address, 'Address');
+is($ii->employees->[3]->address->city, 'Marysville', '... got the right city');
+is($ii->employees->[3]->address->state, 'OH', '... got the right state');
+
+## check some error conditions for the subtypes
+
+dies_ok {
+    Address->new(state => 'British Columbia'),    
+} '... we die correctly with bad args';
+
+lives_ok {
+    Address->new(state => 'Connecticut'),    
+} '... we live correctly with good args';
+
+dies_ok {
+    Address->new(zip_code => 'AF5J6$'),    
+} '... we die correctly with bad args';
+
+lives_ok {
+    Address->new(zip_code => '06443'),    
+} '... we live correctly with good args';
+
+dies_ok {
+    Company->new(employees => [ Person->new ]),    
+} '... we die correctly with good args';
+
+lives_ok {
+    Company->new(employees => []),    
+} '... we live correctly with good args';
+