X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FPurePerl.pm;h=94d57d888749699a97a3d49a398afe7fd874508a;hp=0a626f8105038701732205d868eb955e02fb6128;hb=9b923ac8adb9442186c3f7cc09cd4d307d6458d7;hpb=267711f78bd79835875f805447d3ab802a18f0c4

diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm
index 0a626f8..94d57d8 100644
--- a/lib/Mouse/PurePerl.pm
+++ b/lib/Mouse/PurePerl.pm
@@ -2,8 +2,7 @@ package Mouse::PurePerl;
 
 require Mouse::Util;
 
-package
-    Mouse::Util;
+package Mouse::Util;
 
 use strict;
 use warnings;
@@ -12,6 +11,19 @@ use warnings FATAL => 'redefine'; # to avoid to load Mouse::PurePerl
 
 use B ();
 
+
+# taken from Class/MOP.pm
+sub is_valid_class_name {
+    my $class = shift;
+
+    return 0 if ref($class);
+    return 0 unless defined($class);
+
+    return 1 if $class =~ /\A \w+ (?: :: \w+ )* \z/xms;
+
+    return 0;
+}
+
 sub is_class_loaded {
     my $class = shift;
 
@@ -124,8 +136,7 @@ sub generate_can_predicate_for {
     return $predicate;
 }
 
-package
-    Mouse::Util::TypeConstraints;
+package Mouse::Util::TypeConstraints;
 
 use Scalar::Util qw(blessed looks_like_number openhandle);
 
@@ -138,10 +149,16 @@ sub Defined    {  defined($_[0])  }
 sub Value      {  defined($_[0]) && !ref($_[0]) }
 sub Num        { !ref($_[0]) && looks_like_number($_[0]) }
 sub Int        {  defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ }
-sub Str        {  defined($_[0]) && !ref($_[0]) }
+sub Str        {
+    my($value) = @_;
+    return defined($value) && ref(\$value) eq 'SCALAR';
+}
 
 sub Ref        { ref($_[0]) }
-sub ScalarRef  { ref($_[0]) eq 'SCALAR' }
+sub ScalarRef  {
+    my($value) = @_;
+    return ref($value) eq 'SCALAR'
+}
 sub ArrayRef   { ref($_[0]) eq 'ARRAY'  }
 sub HashRef    { ref($_[0]) eq 'HASH'   }
 sub CodeRef    { ref($_[0]) eq 'CODE'   }
@@ -149,7 +166,7 @@ sub RegexpRef  { ref($_[0]) eq 'Regexp' }
 sub GlobRef    { ref($_[0]) eq 'GLOB'   }
 
 sub FileHandle {
-    openhandle($_[0])  || (blessed($_[0]) && $_[0]->isa("IO::Handle"))
+    return openhandle($_[0])  || (blessed($_[0]) && $_[0]->isa("IO::Handle"))
 }
 
 sub Object     { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }
@@ -189,12 +206,9 @@ sub _parameterize_Maybe_for {
     return sub{
         return !defined($_) || $check->($_);
     };
-};
-
-
+}
 
-package
-    Mouse::Meta::Module;
+package Mouse::Meta::Module;
 
 sub name          { $_[0]->{package} }
 
@@ -230,8 +244,7 @@ sub add_method {
     return;
 }
 
-package
-    Mouse::Meta::Class;
+package Mouse::Meta::Class;
 
 sub method_metaclass    { $_[0]->{method_metaclass}    || 'Mouse::Meta::Method'    }
 sub attribute_metaclass { $_[0]->{attribute_metaclass} || 'Mouse::Meta::Attribute' }
@@ -319,8 +332,9 @@ sub _initialize_object{
 
 sub is_immutable {  $_[0]->{is_immutable} }
 
-package
-    Mouse::Meta::Role;
+sub __strict_constructor{ $_[0]->{strict_constructor} }
+
+package Mouse::Meta::Role;
 
 sub method_metaclass{ $_[0]->{method_metaclass} || 'Mouse::Meta::Role::Method' }
 
@@ -330,8 +344,7 @@ sub is_anon_role{
 
 sub get_roles { $_[0]->{roles} }
 
-package
-    Mouse::Meta::Attribute;
+package Mouse::Meta::Attribute;
 
 require Mouse::Meta::Method::Accessor;
 
@@ -381,13 +394,143 @@ sub has_builder          { exists $_[0]->{builder}         }
 
 sub has_documentation    { exists $_[0]->{documentation}   }
 
-package
-    Mouse::Meta::TypeConstraint;
+sub _process_options{
+    my($class, $name, $args) = @_;
+
+    # taken from Class::MOP::Attribute::new
+
+    defined($name)
+        or $class->throw_error('You must provide a name for the attribute');
+
+    if(!exists $args->{init_arg}){
+        $args->{init_arg} = $name;
+    }
+
+    # 'required' requires eigher 'init_arg', 'builder', or 'default'
+    my $can_be_required = defined( $args->{init_arg} );
+
+    if(exists $args->{builder}){
+        # XXX:
+        # Moose refuses a CODE ref builder, but Mouse doesn't for backward compatibility
+        # This feature will be changed in a future. (gfx)
+        $class->throw_error('builder must be a defined scalar value which is a method name')
+            #if ref $args->{builder} || !defined $args->{builder};
+            if !defined $args->{builder};
+
+        $can_be_required++;
+    }
+    elsif(exists $args->{default}){
+        if(ref $args->{default} && ref($args->{default}) ne 'CODE'){
+            $class->throw_error("References are not allowed as default values, you must "
+                              . "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])");
+        }
+        $can_be_required++;
+    }
+
+    if( $args->{required} && !$can_be_required ) {
+        $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg");
+    }
+
+    # taken from Mouse::Meta::Attribute->new and ->_process_args
+
+    if(exists $args->{is}){
+        my $is = $args->{is};
+
+        if($is eq 'ro'){
+            $args->{reader} ||= $name;
+        }
+        elsif($is eq 'rw'){
+            if(exists $args->{writer}){
+                $args->{reader} ||= $name;
+             }
+             else{
+                $args->{accessor} ||= $name;
+             }
+        }
+        elsif($is eq 'bare'){
+            # do nothing, but don't complain (later) about missing methods
+        }
+        else{
+            $is = 'undef' if !defined $is;
+            $class->throw_error("I do not understand this option (is => $is) on attribute ($name)");
+        }
+    }
+
+    my $tc;
+    if(exists $args->{isa}){
+        $tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($args->{isa});
+    }
+
+    if(exists $args->{does}){
+        if(defined $tc){ # both isa and does supplied
+            my $does_ok = do{
+                local $@;
+                eval{ "$tc"->does($args) };
+            };
+            if(!$does_ok){
+                $class->throw_error("Cannot have both an isa option and a does option because '$tc' does not do '$args->{does}' on attribute ($name)");
+            }
+        }
+        else {
+            $tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($args->{does});
+        }
+    }
+
+    if($args->{coerce}){
+        defined($tc)
+            || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)");
+
+        $args->{weak_ref}
+            && $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)");
+    }
+
+    if ($args->{lazy_build}) {
+        exists($args->{default})
+            && $class->throw_error("You can not use lazy_build and default for the same attribute ($name)");
+
+        $args->{lazy}      = 1;
+        $args->{builder} ||= "_build_${name}";
+        if ($name =~ /^_/) {
+            $args->{clearer}   ||= "_clear${name}";
+            $args->{predicate} ||= "_has${name}";
+        }
+        else {
+            $args->{clearer}   ||= "clear_${name}";
+            $args->{predicate} ||= "has_${name}";
+        }
+    }
+
+    if ($args->{auto_deref}) {
+        defined($tc)
+            || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)");
+
+        ( $tc->is_a_type_of('ArrayRef') || $tc->is_a_type_of('HashRef') )
+            || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)");
+    }
+
+    if (exists $args->{trigger}) {
+        ('CODE' eq ref $args->{trigger})
+            || $class->throw_error("Trigger must be a CODE ref on attribute ($name)");
+    }
+
+    if ($args->{lazy}) {
+        (exists $args->{default} || defined $args->{builder})
+            || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it");
+    }
+
+    return;
+}
+
+
+package Mouse::Meta::TypeConstraint;
 
 sub name    { $_[0]->{name}    }
 sub parent  { $_[0]->{parent}  }
 sub message { $_[0]->{message} }
 
+sub type_parameter { $_[0]->{type_parameter} }
+sub __is_parameterized { exists $_[0]->{type_parameter} }
+
 sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
 
 sub _compiled_type_coercion  { $_[0]->{_compiled_type_coercion}  }
@@ -441,8 +584,7 @@ sub compile_type_constraint{
     return;
 }
 
-package
-    Mouse::Object;
+package Mouse::Object;
 
 
 sub BUILDARGS {
@@ -504,7 +646,7 @@ sub DESTROY {
                 my $demolish = Mouse::Util::get_code_ref($class, 'DEMOLISH')
                     || next;
 
-                $self->$demolish();
+                $self->$demolish($Mouse::Util::in_global_destruction);
             }
         };
         $@;
@@ -541,7 +683,7 @@ Mouse::PurePerl - A Mouse guts in pure Perl
 
 =head1 VERSION
 
-This document describes Mouse version 0.4501
+This document describes Mouse version 0.50_03
 
 =head1 SEE ALSO