From: Stevan Little <stevan.little@iinteractive.com>
Date: Mon, 20 Mar 2006 21:29:21 +0000 (+0000)
Subject: uploading
X-Git-Tag: 0_05~80
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4e036ee4269310099ef139f2fa14673d821f629a;p=gitmo%2FMoose.git

uploading
---

diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm
new file mode 100644
index 0000000..785ba5c
--- /dev/null
+++ b/lib/Moose/Meta/TypeConstraint.pm
@@ -0,0 +1,89 @@
+
+package Moose::Meta::TypeConstraint;
+
+use strict;
+use warnings;
+use metaclass;
+
+Moose::Meta::TypeConstraint->meta->add_attribute(
+    Class::MOP::Attribute->new('name' => (
+        reader => 'name'
+    ))	
+);
+
+Moose::Meta::TypeConstraint->meta->add_attribute(
+    Class::MOP::Attribute->new('constraint_code' => (
+        reader => 'constraint_code'
+    ))	
+);
+
+Moose::Meta::TypeConstraint->meta->add_attribute(
+    Class::MOP::Attribute->new('coercion_code' => (
+        reader    => 'coercion_code',
+        writer    => 'set_coercion_code',        
+        predicate => 'has_coercion'
+    ))	
+);
+
+sub new    { (shift)->meta->new_object(@_)  }
+sub check  { (shift)->constraint_code->(@_) }
+sub coerce { (shift)->coercion_code->(@_)   }
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::TypeConstraint - The Moose Type Constraint metaobject
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item B<meta>
+
+=item B<new>
+
+=item B<name>
+
+=item B<check>
+
+=item B<coerce>
+
+=item B<coercion_code>
+
+=item B<set_coercion_code>
+
+=item B<constraint_code>
+
+=item B<has_coercion>
+
+=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/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index 42c7bef..b2c5db7 100644
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -10,6 +10,8 @@ use Scalar::Util 'blessed';
 
 our $VERSION = '0.02';
 
+use Moose::Meta::TypeConstraint;
+
 sub import {
 	shift;
 	my $pkg = shift || caller();
@@ -24,14 +26,17 @@ sub import {
     my %TYPES;
     sub find_type_constraint { 
         my $type_name = shift;
-        $TYPES{$type_name}; 
+        $TYPES{$type_name}->constraint_code; 
     }
 
     sub register_type_constraint { 
         my ($type_name, $type_constraint) = @_;
         (not exists $TYPES{$type_name})
             || confess "The type constraint '$type_name' has already been registered";
-        $TYPES{$type_name} = $type_constraint;
+        $TYPES{$type_name} = Moose::Meta::TypeConstraint->new(
+            name            => $type_name,
+            constraint_code => $type_constraint
+        );
     }
     
     sub dump_type_constraints {
@@ -44,23 +49,21 @@ sub import {
         my $pkg = caller();
 	    no strict 'refs';
     	foreach my $constraint (keys %TYPES) {
-    		*{"${pkg}::${constraint}"} = $TYPES{$constraint};
+    		*{"${pkg}::${constraint}"} = $TYPES{$constraint}->constraint_code;
     	}        
     }
-}
 
-{
-    my %COERCIONS;
     sub find_type_coercion { 
         my $type_name = shift;
-        $COERCIONS{$type_name}; 
+        $TYPES{$type_name}->coercion_code; 
     }
 
     sub register_type_coercion { 
         my ($type_name, $type_coercion) = @_;
-        (not exists $COERCIONS{$type_name})
+        my $type = $TYPES{$type_name};
+        (!$type->has_coercion)
             || confess "The type coercion for '$type_name' has already been registered";        
-        $COERCIONS{$type_name} = $type_coercion;
+        $type->set_coercion_code($type_coercion);
     }
 }
 
diff --git a/t/006_basic.t b/t/006_basic.t
index 769fc52..726f211 100644
--- a/t/006_basic.t
+++ b/t/006_basic.t
@@ -102,5 +102,16 @@ isa_ok($r, 'Request');
     } '... dies when it gets bad params';
 }
 
+{
+    is($r->protocol, undef, '... got nothing by default');
 
+    lives_ok {
+        $r->protocol('HTTP/1.0');
+    } '... set the protocol correctly';
+    is($r->protocol, 'HTTP/1.0', '... got nothing by default');
+            
+    dies_ok {
+        $r->protocol('http/1.0');
+    } '... the protocol died with bar params correctly';            
+}