lib/Frey/ClassLoader.pm

package Frey::ClassLoader;
use Moose;

=head1 DESCRIPTION

Load L<Frey> classes

=cut

extends 'Frey';
with 'Frey::Session';

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} ) {
                        $self->TODO( "Mojo support" );
                        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_} || 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;
        
        if ( $class->meta->isa('Moose::Meta::Role') ) {
                $instance = Frey->new;
                Frey::Web->meta->apply( $instance );
                warn "new_frey_class $class role with Frey::Web";
        } else {
                $instance = $class->new( %$params ) or confess "can't $class->new".dump( %$params );
                warn "new_frey_class $class";
        }

        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";
        }

        if ( ! $instance->can('add_status') ) {
                Frey::Web->meta->apply( $instance );
                warn "# apply Frey::Web role to $class";
        }

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

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