The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
ETHER / Moose-2.2010 / t / exceptions / class-mop-class.t 
use strict;
use warnings;

use Test::More;
use Test::Fatal;

use Moose();

{
    my $exception =  exception {
        my $class = Class::MOP::Class::initialize;
    };

    like(
        $exception,
        qr/You must pass a package name and it cannot be blessed/,
        "no package name given to initialize");

    isa_ok(
        $exception,
        "Moose::Exception::InitializeTakesUnBlessedPackageName",
        "no package name given to initialize");
}

{
    my $exception =  exception {
        my $class = Class::MOP::Class::create("Foo" => ( superclasses => ('foo') ));
    };

    like(
        $exception,
        qr/You must pass an ARRAY ref of superclasses/,
        "an Array is of superclasses is passed");

    isa_ok(
        $exception,
        "Moose::Exception::CreateMOPClassTakesArrayRefOfSuperclasses",
        "an Array is of superclasses is passed");

    is(
        $exception->class,
        'Foo',
        "an Array is of superclasses is passed");
}


{
    my $exception =  exception {
        my $class = Class::MOP::Class::create("Foo" => ( attributes => ('foo') ));
    };

    like(
        $exception,
        qr/You must pass an ARRAY ref of attributes/,
        "an Array is of attributes is passed");

    isa_ok(
        $exception,
        "Moose::Exception::CreateMOPClassTakesArrayRefOfAttributes",
        "an Array is of attributes is passed");

    is(
        $exception->class,
        'Foo',
        "an Array is of attributes is passed");
}

{
    my $exception =  exception {
        my $class = Class::MOP::Class::create("Foo" => ( methods => ('foo') ) );
    };

    like(
        $exception,
        qr/You must pass an HASH ref of methods/,
        "a Hash is of methods is passed");

    isa_ok(
        $exception,
        "Moose::Exception::CreateMOPClassTakesHashRefOfMethods",
        "a Hash is of methods is passed");

    is(
        $exception->class,
        'Foo',
        "a Hash is of methods is passed");
}

{
    my $exception =  exception {
        my $class = Class::MOP::Class->create("Foo");
        $class->find_method_by_name;
    };

    like(
        $exception,
        qr/You must define a method name to find/,
        "no method name given to find_method_by_name");

    isa_ok(
        $exception,
        "Moose::Exception::MethodNameNotGiven",
        "no method name given to find_method_by_name");

    is(
        $exception->class_name,
        'Foo',
        "no method name given to find_method_by_name");
}

{
    my $exception =  exception {
        my $class = Class::MOP::Class->create("Foo");
        $class->find_all_methods_by_name;
    };

    like(
        $exception,
        qr/You must define a method name to find/,
        "no method name given to find_all_methods_by_name");

    isa_ok(
        $exception,
        "Moose::Exception::MethodNameNotGiven",
        "no method name given to find_all_methods_by_name");

    is(
        $exception->class_name,
        'Foo',
        "no method name given to find_all_methods_by_name");
}

{
    my $exception =  exception {
        my $class = Class::MOP::Class->create("Foo");
        $class->find_next_method_by_name;
    };

    like(
        $exception,
        qr/You must define a method name to find/,
        "no method name given to find_next_method_by_name");

    isa_ok(
        $exception,
        "Moose::Exception::MethodNameNotGiven",
        "no method name given to find_next_method_by_name");

    is(
        $exception->class_name,
        'Foo',
        "no method name given to find_next_method_by_name");
}

{
    my $class = Class::MOP::Class->create("Foo");
    my $foo = "foo";
    my $exception =  exception {
        $class->clone_object( $foo );
    };

    like(
        $exception,
        qr/\QYou must pass an instance of the metaclass (Foo), not (foo)/,
        "clone_object expects an instance of the metaclass");

    isa_ok(
        $exception,
        "Moose::Exception::CloneObjectExpectsAnInstanceOfMetaclass",
        "clone_object expects an instance of the metaclass");

    is(
        $exception->class_name,
        'Foo',
        "clone_object expects an instance of the metaclass");

   is(
        $exception->instance,
        'foo',
        "clone_object expects an instance of the metaclass");
}

{
    {
        package Foo;
        use Moose;
    }
    {
        package Foo2;
        use Moose;
    }
    my $foo2 = Foo2->new;
    my $exception =  exception {
        Foo->meta->rebless_instance( $foo2 );
    };

    like(
        $exception,
        qr/\QYou may rebless only into a subclass of (Foo2), of which (Foo) isn't./,
        "you can rebless only into subclass");

    isa_ok(
        $exception,
        "Moose::Exception::CanReblessOnlyIntoASubclass",
        "you can rebless only into subclass");

    is(
        $exception->class_name,
        'Foo',
        "you can rebless only into subclass");

   is(
        $exception->instance,
        $foo2,
        "you can rebless only into subclass");
}

{
    {
        package Foo;
        use Moose;
    }
    {
        package Foo2;
        use Moose;
    }
    my $foo = Foo->new;
    my $exception =  exception {
        Foo2->meta->rebless_instance_back( $foo );
    };

    like(
        $exception,
        qr/\QYou may rebless only into a superclass of (Foo), of which (Foo2) isn't./,
        "you can rebless only into superclass");

    isa_ok(
        $exception,
        "Moose::Exception::CanReblessOnlyIntoASuperclass",
        "you can rebless only into superclass");

    is(
        $exception->instance,
        $foo,
        "you can rebless only into superclass");

   is(
        $exception->class_name,
        "Foo2",
        "you can rebless only into superclass");
}

{
    {
        package Foo;
        use Moose;
    }
    my $exception =  exception {
        Foo->meta->add_before_method_modifier;
    };

    like(
        $exception,
        qr/You must pass in a method name/,
        "no method name passed to method modifier");

    isa_ok(
        $exception,
        "Moose::Exception::MethodModifierNeedsMethodName",
        "no method name passed to method modifier");

    is(
        $exception->class_name,
        "Foo",
        "no method name passed to method modifier");
}

{
    {
        package Foo;
        use Moose;
    }
    my $exception =  exception {
        Foo->meta->add_after_method_modifier;
    };

    like(
        $exception,
        qr/You must pass in a method name/,
        "no method name passed to method modifier");

    isa_ok(
        $exception,
        "Moose::Exception::MethodModifierNeedsMethodName",
        "no method name passed to method modifier");

    is(
        $exception->class_name,
        "Foo",
        "no method name passed to method modifier");
}

{
    {
        package Foo;
        use Moose;
    }
    my $exception =  exception {
        Foo->meta->add_around_method_modifier;
    };

    like(
        $exception,
        qr/You must pass in a method name/,
        "no method name passed to method modifier");

    isa_ok(
        $exception,
        "Moose::Exception::MethodModifierNeedsMethodName",
        "no method name passed to method modifier");

    is(
        $exception->class_name,
        "Foo",
        "no method name passed to method modifier");
}

{
    my $exception =  exception {
        my $class = Class::MOP::Class->_construct_class_instance;
    };

    like(
        $exception,
        qr/You must pass a package name/,
        "no package name given to _construct_class_instance");

    isa_ok(
        $exception,
        "Moose::Exception::ConstructClassInstanceTakesPackageName",
        "no package name given to _construct_class_instance");
}

{
    my $class = Class::MOP::Class->create("Foo");
    my $exception =  exception {
        $class->add_before_method_modifier("foo");
    };

    like(
        $exception,
        qr/The method 'foo' was not found in the inheritance hierarchy for Foo/,
        'method "foo" is not defined in class "Foo"');

    isa_ok(
        $exception,
        "Moose::Exception::MethodNameNotFoundInInheritanceHierarchy",
        'method "foo" is not defined in class "Foo"');

    is(
        $exception->class_name,
        'Foo',
        'method "foo" is not defined in class "Foo"');

   is(
        $exception->method_name,
        'foo',
        'method "foo" is not defined in class "Foo"');
}

{
    {
        package Bar;
        use Moose;
    }
    my $bar = Bar->new;
    my $class = Class::MOP::Class->create("Foo");
    my $exception =  exception {
        $class->new_object( ( __INSTANCE__ => $bar ) );
    };

    like(
        $exception,
        qr/\QObjects passed as the __INSTANCE__ parameter must already be blessed into the correct class, but $bar is not a Foo/,
        "__INSTANCE__ is not blessed correctly");
        #Objects passed as the __INSTANCE__ parameter must already be blessed into the correct class, but Bar=HASH(0x2d77528) is not a Foo

    isa_ok(
        $exception,
        "Moose::Exception::InstanceBlessedIntoWrongClass",
        "__INSTANCE__ is not blessed correctly");

    is(
        $exception->class_name,
        'Foo',
        "__INSTANCE__ is not blessed correctly");

   is(
        $exception->instance,
        $bar,
        "__INSTANCE__ is not blessed correctly");
}

{
    my $class = Class::MOP::Class->create("Foo");
    my $array = [1,2,3];
    my $exception =  exception {
        $class->new_object( ( __INSTANCE__ => $array ) );
    };

    like(
        $exception,
        qr/\QThe __INSTANCE__ parameter must be a blessed reference, not $array/,
        "__INSTANCE__ is not a blessed reference");
        #The __INSTANCE__ parameter must be a blessed reference, not ARRAY(0x1d75d40)

    isa_ok(
        $exception,
        "Moose::Exception::InstanceMustBeABlessedReference",
        "__INSTANCE__ is not a blessed reference");

    is(
        $exception->class_name,
        'Foo',
        "__INSTANCE__ is not a blessed reference");

   is(
        $exception->instance,
        $array,
        "__INSTANCE__ is not a blessed reference");
}

{
    my $array = [1, 2, 3];
    my $class = Class::MOP::Class->create("Foo");
    my $exception =  exception {
        $class->_clone_instance($array);
    };

    like(
        $exception,
        qr/\QYou can only clone instances, ($array) is not a blessed instance/,
        "array reference was passed to _clone_instance instead of a blessed instance");
        #You can only clone instances, (ARRAY(0x2162350)) is not a blessed instance

    isa_ok(
        $exception,
        "Moose::Exception::OnlyInstancesCanBeCloned",
        "array reference was passed to _clone_instance instead of a blessed instance");

    is(
        $exception->class_name,
        "Foo",
        "array reference was passed to _clone_instance instead of a blessed instance");

    is(
        $exception->instance,
        $array,
        "array reference was passed to _clone_instance instead of a blessed instance");
}

{
    {
        package My::Role;
        use Moose::Role;
    }

    my $exception = exception {
        Class::MOP::Class->create("My::Class", superclasses => ["My::Role"]);
    };

    like(
        $exception,
        qr/\QThe metaclass of My::Class (Class::MOP::Class) is not compatible with the metaclass of its superclass, My::Role (Moose::Meta::Role) /,
        "Trying to inherit a Role");

    isa_ok(
        $exception,
        "Moose::Exception::IncompatibleMetaclassOfSuperclass",
        "Trying to inherit a Role");

    is(
        $exception->class_name,
        "My::Class",
        "Trying to inherit a Role");

    is(
        $exception->superclass_name,
        "My::Role",
        "Trying to inherit a Role");
}

{
    {
        package Super::Class;
        use Moose;
    }

    my $class = Class::MOP::Class->create("TestClass", superclasses => ["Super::Class"]);
    $class->immutable_trait(undef);
    my $exception = exception {
        $class->make_immutable( immutable_trait => '');
    };

    like(
        $exception,
        qr/\Qno immutable trait specified for $class/,
        "immutable_trait set to undef");
        #no immutable trait specified for Moose::Meta::Class=HASH(0x19a2280)

    isa_ok(
        $exception,
        "Moose::Exception::NoImmutableTraitSpecifiedForClass",
        "immutable_trait set to undef");

    is(
        $exception->class_name,
        "TestClass",
        "immutable_trait set to undef");
}

{
    my $exception = exception {
        package NoDestructorClass;
        use Moose;

        __PACKAGE__->meta->make_immutable( destructor_class => undef, inline_destructor => 1 );
    };

    like(
        $exception,
        qr/The 'inline_destructor' option is present, but no destructor class was specified/,
        "destructor_class is set to undef");

    isa_ok(
        $exception,
        "Moose::Exception::NoDestructorClassSpecified",
        "destructor_class is set to undef");

    is(
        $exception->class_name,
        "NoDestructorClass",
        "destructor_class is set to undef");
}

{
    {
        package Foo9::Meta::Role;
        use Moose::Role;
    }

    {
        package Foo9::SuperClass::WithMetaRole;
        use Moose -traits =>'Foo9::Meta::Role';
    }

    {
        package Foo9::Meta::OtherRole;
        use Moose::Role;
    }

    {
        package Foo9::SuperClass::After::Attribute;
        use Moose -traits =>'Foo9::Meta::OtherRole';
    }

    my $exception = exception {
        {
            package Foo9;
            use Moose;
            my @superclasses = ('Foo9::SuperClass::WithMetaRole');
            extends @superclasses;

            has an_attribute_generating_methods => ( is => 'ro' );

            push(@superclasses, 'Foo9::SuperClass::After::Attribute');

            extends @superclasses;
        }
    };

    like(
        $exception,
        qr/\QCan't fix metaclass incompatibility for Foo9 because it is not pristine./,
        "cannot make metaclass compatible");

    isa_ok(
        $exception,
        "Moose::Exception::CannotFixMetaclassCompatibility",
        "cannot make metaclass compatible");

    is(
        $exception->class_name,
        "Foo9",
        "cannot make metaclass compatible");
}

{
    Class::MOP::Class->create( "Foo::Meta::Attribute",
                               superclasses => ["Class::MOP::Attribute"]
                             );

    Class::MOP::Class->create( "Bar::Meta::Attribute",
                               superclasses => ["Class::MOP::Attribute"]
                             );

    Class::MOP::Class->create( "Foo::Meta::Class",
                               superclasses => ["Class::MOP::Class"]
                             );

    Foo::Meta::Class->create(
        'Foo::All',
        attribute_metaclass => "Foo::Meta::Attribute",
    );

    {
        Class::MOP::Class->create(
            'Foo::Unsafe',
            attribute_metaclass => 'Foo::Meta::Attribute',
        );

        my $meta = Class::MOP::Class->create(
            'Foo::Unsafe::Sub',
        );

        $meta->add_attribute(foo => reader => 'foo');

        my $exception = exception {
            $meta->superclasses('Foo::Unsafe');
        };

        like(
            $exception,
            qr/\QCan't fix metaclass incompatibility for Foo::Unsafe::Sub because it is not pristine./,
            "cannot make metaclass compatible");

        isa_ok(
            $exception,
            "Moose::Exception::CannotFixMetaclassCompatibility",
            "cannot make metaclass compatible");

        is(
            $exception->class_name,
            "Foo::Unsafe::Sub",
            "cannot make metaclass compatible");
    }

    {
        my $exception = exception {
            Foo::Meta::Class->create(
                "Foo::All::Sub::Attribute",
                superclasses        => ['Foo::All'],
                attribute_metaclass => "Foo::Meta::Attribute",
                attribute_metaclass => "Bar::Meta::Attribute",
            )
        };

        like(
            $exception,
            qr/\QThe attribute_metaclass metaclass for Foo::All::Sub::Attribute (Bar::Meta::Attribute) is not compatible with the attribute metaclass of its superclass, Foo::All (Foo::Meta::Attribute)/,
            "incompatible attribute_metaclass");

        isa_ok(
            $exception,
            "Moose::Exception::MetaclassTypeIncompatible",
            "incompatible attribute_metaclass");

        is(
            $exception->class_name,
            "Foo::All::Sub::Attribute",
            "incompatible attribute_metaclass");

        is(
            $exception->superclass_name,
            "Foo::All",
            "incompatible attribute_metaclass");

        is(
            $exception->metaclass_type,
            "attribute_metaclass",
            "incompatible attribute_metaclass");
    }
}

done_testing;