lib/Frey/ClassLoader.pm

package Frey::ClassLoader;
use Moose;

=head1 DESCRIPTION

Load L<Frey> classes

=cut

extends 'Frey';

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

our $class_path;
our @classes;

=head2 classes

Return all local classes by reading from disk

  my @classes = $o->classes;

=cut

sub classes {
        my $self = shift;
        return @classes if @classes;

        # FIXME there must be better way to do this in Moose style
        finddepth({ no_chdir => 1, wanted => sub {
                return unless m{\.pm$};
                my $class = $_;
                $class =~ s{^lib/}{};
                $class =~ s{\.pm$}{};
                $class =~ s{/}{::}g;
                if ( $class =~ m{Mojo} ) {
                        warn "# skip Mojo class $class";
                        return;
                }
                $class_path->{ $class } = $_;
        } }, 'lib');
        warn "## class_path = ",dump( $class_path ) if $self->debug;

        @classes = sort keys %$class_path;
}

=head2 class_path

Return any local or loaded class

  $path = $o->class_path( $class );

=cut

sub class_path {
        my ( $self, $class ) = @_;
        $self->classes unless $class_path;
        if ( ! defined $class_path->{$class} ) {
                my $path = $class;
                $path =~ s{::}{/}g;
                $path .= '.pm';
                $path = $INC{$path};
                warn "# $class from INC $path";
                $class_path->{$class} = $path || confess "can't find path for $class";
        }
        return $class_path->{$class};
}

=head2 loaded_classes

  my $available = $o->loaded_classes;
  $available->{'Frey'} # true

=cut

our $loaded_class;
sub loaded_classes { $loaded_class };

=head2 class_meta

  my ( $meta, $is_role, $instance ) = $o->class_meta( 'Some::Class' );

=cut

sub class_meta {
        my ( $self, $class ) = @_;

        $class ||= $self->class if $self->can('class');
        warn "# class_meta $class";

        $self->load_class($class);

        my $meta;
        my $is_role = 0;
        my $instance;

        if ( ! $class->can('meta') ) {
                $instance = Moose::Meta::Class->create_anon_class;
                warn "# class $class isn't Moose, faking anon class" if $self->debug;
                $meta = $instance->meta;
        } elsif( $class->meta->isa('Moose::Meta::Role') ) {
                $is_role = 1;
                $instance = Frey->new;
                warn "# apply $class on $instance";
                $class->meta->apply( $instance );
                $meta = $instance->meta;
        } else {
                $meta = $class->meta;
        }
        return ( $meta, $is_role, $instance );
}

sub load_class {
        my ( $self, $class ) = @_;
        return if $loaded_class->{$class}++;
        eval {
                Class::MOP::load_class($class)
        };
        warn $@ if $@; # && $@ !~ m/role/;
        warn "# load_class $class" if $self->debug && $loaded_class->{$class} == 1;
}

sub load_all_classes {
        my $self = shift;
        warn "# loaded_class = ",dump( $loaded_class ) if $self->debug;
        $self->load_class( $_ ) foreach ( $self->classes );
        $loaded_class;
}

=head2 class_methods

  my @all_methods = $o->class_methods( $class );

  my $class_method = $o->class_methods( $class );
  if ( $class_method->{ $method } ) {
        # $class has $method
  }

=cut

sub class_methods {
        my ( $self, $class ) = @_;

        confess "need class" unless $class;
        if ( ! $class->can('meta') ) {
                warn "# $class doesn't have meta (isn't Moose class)" if $self->debug;
                return;
        }
        my $meta = $class->meta;

        my $attr;
        my $methods;
        $attr->{$_}++ foreach $meta->get_attribute_list;
        my @methods = map { $methods->{$_}++; $_ } grep { ! defined($attr->{$_}) && $_ ne 'meta' } $meta->get_method_list;
        warn "# methods = ",dump( @methods ) if $self->debug;

        return @methods if wantarray;
        return $methods;
}

=head2 class_runnable

  my @runnable_methods = $o->class_runnable( $class );

=cut

sub class_runnable {
        my ( $self, $class ) = @_;
        my @methods = grep { m{^as_} } $self->class_methods( $class );
        return @methods if wantarray;
        return \@methods;
}

sub class_inputs {
        my ( $self, $class ) = @_;
        my @inputs = grep { m{^(markup/as_data/as_sponge)$} } $self->class_methods( $class );
        return @inputs if wantarray;
        return \@inputs;
}

=head2 new_frey_class

  my $instance = $o->new_frey_class( $class, $params );

This will apply L<Moose::Role> on the fly to provide accessors for
C<data> and C<sponge> in form of C<as_*>

See L<http://www.perlmonks.org/?node_id=602389>

It is used by L<Frey::Run> and L<Frey::Pipe> to create objects

=cut

{
        package Frey::Role::as_data;
        use Moose::Role;

        sub as_data {
                my ($self) = @_;
                $self->data;
        }

        package Frey::Role::as_sponge;
        use Moose::Role;
        sub as_sponge {
                my ($self) = @_;
                $self->sponge;
        }
}

sub new_frey_class {
        my ( $self, $class, $params ) = @_;
        my $instance = $class->new( %$params );
        if ( $instance->can('data') && ! $instance->can('as_data') ) {
                Frey::Role::as_data->meta->apply( $instance );
                warn "# apply as_data role to $class";
        }
        if ( $instance->can('sponge') && ! $instance->can('as_sponge') ) {
                Frey::Role::as_sponge->meta->apply( $instance );
                warn "# apply as_sponge role to $class";
        }

        $self->add_status({ $class => $params }) if $self->can('add_status');
        return $instance;
}

1;
1	package Frey::ClassLoader;
2	use Moose;
3
4	=head1 DESCRIPTION
5
6	Load L<Frey> classes
7
8	=cut
9
10	extends 'Frey';
11
12	use Data::Dump qw/dump/;
13	use File::Find;
14
15	our $class_path;
16	our @classes;
17
18	=head2 classes
19
20	Return all local classes by reading from disk
21
22	my @classes = $o->classes;
23
24	=cut
25
26	sub classes {
27	my $self = shift;
28	return @classes if @classes;
29
30	# FIXME there must be better way to do this in Moose style
31	finddepth({ no_chdir => 1, wanted => sub {
32	return unless m{\.pm$};
33	my $class = $_;
34	$class =~ s{^lib/}{};
35	$class =~ s{\.pm$}{};
36	$class =~ s{/}{::}g;
37	if ( $class =~ m{Mojo} ) {
38	warn "# skip Mojo class $class";
39	return;
40	}
41	$class_path->{ $class } = $_;
42	} }, 'lib');
43	warn "## class_path = ",dump( $class_path ) if $self->debug;
44
45	@classes = sort keys %$class_path;
46	}
47
48	=head2 class_path
49
50	Return any local or loaded class
51
52	$path = $o->class_path( $class );
53
54	=cut
55
56	sub class_path {
57	my ( $self, $class ) = @_;
58	$self->classes unless $class_path;
59	if ( ! defined $class_path->{$class} ) {
60	my $path = $class;
61	$path =~ s{::}{/}g;
62	$path .= '.pm';
63	$path = $INC{$path};
64	warn "# $class from INC $path";
65	$class_path->{$class} = $path \|\| confess "can't find path for $class";
66	}
67	return $class_path->{$class};
68	}
69
70	=head2 loaded_classes
71
72	my $available = $o->loaded_classes;
73	$available->{'Frey'} # true
74
75	=cut
76
77	our $loaded_class;
78	sub loaded_classes { $loaded_class };
79
80	=head2 class_meta
81
82	my ( $meta, $is_role, $instance ) = $o->class_meta( 'Some::Class' );
83
84	=cut
85
86	sub class_meta {
87	my ( $self, $class ) = @_;
88
89	$class \|\|= $self->class if $self->can('class');
90	warn "# class_meta $class";
91
92	$self->load_class($class);
93
94	my $meta;
95	my $is_role = 0;
96	my $instance;
97
98	if ( ! $class->can('meta') ) {
99	$instance = Moose::Meta::Class->create_anon_class;
100	warn "# class $class isn't Moose, faking anon class" if $self->debug;
101	$meta = $instance->meta;
102	} elsif( $class->meta->isa('Moose::Meta::Role') ) {
103	$is_role = 1;
104	$instance = Frey->new;
105	warn "# apply $class on $instance";
106	$class->meta->apply( $instance );
107	$meta = $instance->meta;
108	} else {
109	$meta = $class->meta;
110	}
111	return ( $meta, $is_role, $instance );
112	}
113
114	sub load_class {
115	my ( $self, $class ) = @_;
116	return if $loaded_class->{$class}++;
117	eval {
118	Class::MOP::load_class($class)
119	};
120	warn $@ if $@; # && $@ !~ m/role/;
121	warn "# load_class $class" if $self->debug && $loaded_class->{$class} == 1;
122	}
123
124	sub load_all_classes {
125	my $self = shift;
126	warn "# loaded_class = ",dump( $loaded_class ) if $self->debug;
127	$self->load_class( $_ ) foreach ( $self->classes );
128	$loaded_class;
129	}
130
131	=head2 class_methods
132
133	my @all_methods = $o->class_methods( $class );
134
135	my $class_method = $o->class_methods( $class );
136	if ( $class_method->{ $method } ) {
137	# $class has $method
138	}
139
140	=cut
141
142	sub class_methods {
143	my ( $self, $class ) = @_;
144
145	confess "need class" unless $class;
146	if ( ! $class->can('meta') ) {
147	warn "# $class doesn't have meta (isn't Moose class)" if $self->debug;
148	return;
149	}
150	my $meta = $class->meta;
151
152	my $attr;
153	my $methods;
154	$attr->{$_}++ foreach $meta->get_attribute_list;
155	my @methods = map { $methods->{$_}++; $_ } grep { ! defined($attr->{$_}) && $_ ne 'meta' } $meta->get_method_list;
156	warn "# methods = ",dump( @methods ) if $self->debug;
157
158	return @methods if wantarray;
159	return $methods;
160	}
161
162	=head2 class_runnable
163
164	my @runnable_methods = $o->class_runnable( $class );
165
166	=cut
167
168	sub class_runnable {
169	my ( $self, $class ) = @_;
170	my @methods = grep { m{^as_} } $self->class_methods( $class );
171	return @methods if wantarray;
172	return \@methods;
173	}
174
175	sub class_inputs {
176	my ( $self, $class ) = @_;
177	my @inputs = grep { m{^(markup/as_data/as_sponge)$} } $self->class_methods( $class );
178	return @inputs if wantarray;
179	return \@inputs;
180	}
181
182	=head2 new_frey_class
183
184	my $instance = $o->new_frey_class( $class, $params );
185
186	This will apply L<Moose::Role> on the fly to provide accessors for
187	C<data> and C<sponge> in form of C<as_*>
188
189	See L<http://www.perlmonks.org/?node_id=602389>
190
191	It is used by L<Frey::Run> and L<Frey::Pipe> to create objects
192
193	=cut
194
195	{
196	package Frey::Role::as_data;
197	use Moose::Role;
198
199	sub as_data {
200	my ($self) = @_;
201	$self->data;
202	}
203
204	package Frey::Role::as_sponge;
205	use Moose::Role;
206	sub as_sponge {
207	my ($self) = @_;
208	$self->sponge;
209	}
210	}
211
212	sub new_frey_class {
213	my ( $self, $class, $params ) = @_;
214	my $instance = $class->new( %$params );
215	if ( $instance->can('data') && ! $instance->can('as_data') ) {
216	Frey::Role::as_data->meta->apply( $instance );
217	warn "# apply as_data role to $class";
218	}
219	if ( $instance->can('sponge') && ! $instance->can('as_sponge') ) {
220	Frey::Role::as_sponge->meta->apply( $instance );
221	warn "# apply as_sponge role to $class";
222	}
223
224	$self->add_status({ $class => $params }) if $self->can('add_status');
225	return $instance;
226	}
227
228	1;