X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FPurePerl.pm;h=802289d257e83fe750a4df8597e0f2d23064179b;hp=80537c91f202345647cc5622f161afc6a96b7637;hb=6514735e9b5d79f955badf9f50970ee768a44337;hpb=80efe91126e926233fade8bdd58288929286fc09

diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm
index 80537c9..802289d 100644
--- a/lib/Mouse/PurePerl.pm
+++ b/lib/Mouse/PurePerl.pm
@@ -138,10 +138,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 +155,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' }
@@ -381,6 +387,123 @@ sub has_builder          { exists $_[0]->{builder}         }
 
 sub has_documentation    { exists $_[0]->{documentation}   }
 
+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}){
+        $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($args->{isa});
+    }
+    elsif(exists $args->{does}){
+        $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($args->{does});
+    }
+    $tc = $args->{type_constraint};
+
+    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;
 
@@ -504,7 +627,7 @@ sub DESTROY {
                 my $demolish = Mouse::Util::get_code_ref($class, 'DEMOLISH')
                     || next;
 
-                $self->$demolish();
+                $self->$demolish($Mouse::Util::in_global_destruction);
             }
         };
         $@;
@@ -541,7 +664,7 @@ Mouse::PurePerl - A Mouse guts in pure Perl
 
 =head1 VERSION
 
-This document describes Mouse version 0.44
+This document describes Mouse version 0.50
 
 =head1 SEE ALSO