Frey/Class/Loader.pm

package Frey::Class::Loader;
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 ( 0 && $class =~ m{Mojo} ) { # FIXME remove dead code
                        $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';
                if ( defined $INC{$path} ) {
                        $path = $INC{$path};
                        warn "# $class from INC $path";
                        $class_path->{$class} = $path;
                } elsif ( $path =~ s{\.pm$}{} && -e "lib/${path}.pod" ) {
                        return "lib/${path}.pod";
                } else {
                        confess "can't find $class at $path";
                }
        }
        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 "# use meta from role $class";
                $meta = ref $class ? ref($class)->meta : $class->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_re { m{^as_} || m{_as_} || m{sql} }

sub class_runnable {
        my ( $self, $class ) = @_;
        my @methods = grep { class_runnable_re } $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;
        }

        no Moose::Role;
}

our $syntax_checked_last;

sub new_frey_class {
        my ( $self, $class, $params ) = @_;
        my $instance;

        my $path = $self->class_path( $class );
        if ( $syntax_checked_last->{$class} != -C $path ) {
                my $syntax = `perl -Ilib -wc $path 2>&1`;
                warn "# syntax: $syntax";
                $syntax_checked_last->{$class} = -C $class;
        }

        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 {
                if ( $self->can('request_url') ) {
                        $params->{request_url} = $self->request_url;
                } else {
                        warn "## $self doesn't have request_url";
                }
                $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;
}

__PACKAGE__->meta->make_immutable;
no Moose;

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