#!/usr/bin/perl use strict; use warnings; use Test::More tests => 12; BEGIN { use_ok('Moose::Policy'); } BEGIN { package My::Plain::Attribute; use Moose; extends 'Moose::Meta::Attribute'; } BEGIN { package My::Bar::Attribute; use Moose; extends 'Moose::Meta::Attribute'; } BEGIN { package My::Plain::Class; use Moose; extends 'Moose::Meta::Class'; } BEGIN { package My::Bar::Class; use Moose; extends 'Moose::Meta::Class'; } BEGIN { package My::Moose::Policy; # because writing subs is hard my %pkg_map = ( qw(metaclass Class), qw(attribute_metaclass Attribute), # TODO these: # qw(method_metaclass Method), # qw(instance_metaclass Instance), ); foreach my $subname (keys(%pkg_map)) { my $pkg = $pkg_map{$subname}; my $sub = sub { my $self = shift; my ($caller) = @_; return('My::Bar::' . $pkg) if($caller =~ m/^Bar(?:::|$)/); return 'My::Plain::' . $pkg; }; no strict 'refs'; *{$subname} = $sub; } } { package Foo; use Moose::Policy 'My::Moose::Policy'; } { package Bar; use Moose::Policy 'My::Moose::Policy'; } { package Bars; use Moose::Policy 'My::Moose::Policy'; } { package Bar::None; use Moose::Policy 'My::Moose::Policy'; } isa_ok(Foo->meta, 'Moose::Meta::Class'); is(Foo->meta->attribute_metaclass, 'My::Plain::Attribute', '... got our custom attr metaclass'); isa_ok(Bar->meta, 'Moose::Meta::Class'); isa_ok(Bar->meta, 'My::Bar::Class'); is(Bar->meta->attribute_metaclass, 'My::Bar::Attribute', '... got our custom attr metaclass'); isa_ok(Bars->meta, 'Moose::Meta::Class'); isa_ok(Bars->meta, 'My::Plain::Class'); is(Bars->meta->attribute_metaclass, 'My::Plain::Attribute', '... got our custom attr metaclass'); isa_ok(Bar::None->meta, 'Moose::Meta::Class'); isa_ok(Bar::None->meta, 'My::Bar::Class'); is(Bar::None->meta->attribute_metaclass, 'My::Bar::Attribute', '... got our custom attr metaclass');