lib/Frey/ClassLoader.pm

package Frey::ClassLoader;
use Moose;

extends 'Frey';

use Data::Dump qw/dump/;
use File::Find;

has 'classes' => (
        is => 'ro',
#       isa => 'HashRef[Str]',
        default => sub {
                my $self = shift;
                # FIXME there must be better way to do this in Moose style
                my $classes;
                finddepth({ no_chdir => 1, wanted => sub {
                        return unless s/\.pm$//;
                        my @a = split(m!/!,$_);
                        my $package = join('::', @a[ 1 .. $#a ]);
                        warn ">> $_ ",dump( @a ), " >> $package\n" if $self->debug;
                        push @$classes, { $package => "$_.pm" };
                } }, 'lib');
                warn "## classes = ",dump( $classes ) if $self->debug;
                $classes;
        },
        lazy => 1,
);

=head2 load_package

  my ( $class, $meta, $is_role ) = $o->load_package( 'Some::Package' );

=cut

sub load_package {
        my ( $self, $package ) = @_;

        #intercept role application so we can accurately generate
        #method and attribute information for the parent class.
        #this is fragile, but there is not better way that i am aware of
        my $rmeta = Moose::Meta::Role->meta;
        $rmeta->make_mutable if $rmeta->is_immutable;
        my $original_apply = $rmeta->get_method("apply")->body;
        $rmeta->remove_method("apply");
        my @roles_to_apply;
        $rmeta->add_method("apply", sub{push(@roles_to_apply, [@_])});
        #load the package with the hacked Moose::Meta::Role

        #eval { Class::MOP::load_class($package); };
        #confess "Failed to load package ${package} $@" if $@;
        Class::MOP::load_class($package);

        my $meta = $package->meta;

        my ($class, $is_role);
        if($package->meta->isa('Moose::Meta::Role')){
                $is_role = 1;
                # we need to apply the role to a class to be able to properly introspect it
                $class = Moose::Meta::Class->create_anon_class;
                $original_apply->($meta, $class);
        } else {
                #roles don't have superclasses ...
                $class = $meta;
        }
        return ( $class, $meta, $is_role );
}


1;
1	package Frey::ClassLoader;
2	use Moose;
3
4	extends 'Frey';
5
6	use Data::Dump qw/dump/;
7	use File::Find;
8
9	has 'classes' => (
10	is => 'ro',
11	# isa => 'HashRef[Str]',
12	default => sub {
13	my $self = shift;
14	# FIXME there must be better way to do this in Moose style
15	my $classes;
16	finddepth({ no_chdir => 1, wanted => sub {
17	return unless s/\.pm$//;
18	my @a = split(m!/!,$_);
19	my $package = join('::', @a[ 1 .. $#a ]);
20	warn ">> $_ ",dump( @a ), " >> $package\n" if $self->debug;
21	push @$classes, { $package => "$_.pm" };
22	} }, 'lib');
23	warn "## classes = ",dump( $classes ) if $self->debug;
24	$classes;
25	},
26	lazy => 1,
27	);
28
29	=head2 load_package
30
31	my ( $class, $meta, $is_role ) = $o->load_package( 'Some::Package' );
32
33	=cut
34
35	sub load_package {
36	my ( $self, $package ) = @_;
37
38	#intercept role application so we can accurately generate
39	#method and attribute information for the parent class.
40	#this is fragile, but there is not better way that i am aware of
41	my $rmeta = Moose::Meta::Role->meta;
42	$rmeta->make_mutable if $rmeta->is_immutable;
43	my $original_apply = $rmeta->get_method("apply")->body;
44	$rmeta->remove_method("apply");
45	my @roles_to_apply;
46	$rmeta->add_method("apply", sub{push(@roles_to_apply, [@_])});
47	#load the package with the hacked Moose::Meta::Role
48
49	#eval { Class::MOP::load_class($package); };
50	#confess "Failed to load package ${package} $@" if $@;
51	Class::MOP::load_class($package);
52
53	my $meta = $package->meta;
54
55	my ($class, $is_role);
56	if($package->meta->isa('Moose::Meta::Role')){
57	$is_role = 1;
58	# we need to apply the role to a class to be able to properly introspect it
59	$class = Moose::Meta::Class->create_anon_class;
60	$original_apply->($meta, $class);
61	} else {
62	#roles don't have superclasses ...
63	$class = $meta;
64	}
65	return ( $class, $meta, $is_role );
66	}
67
68
69	1;