/[Frey]/trunk/lib/Frey/ClassLoader.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk/lib/Frey/ClassLoader.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 687 - (show annotations)
Tue Dec 2 19:01:32 2008 UTC (15 years, 3 months ago) by dpavlin
File size: 5729 byte(s)
return .pod paths so we can introspect pure pod documents
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 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 "# apply $class on $instance";
113 $class->meta->apply( $instance );
114 $meta = $instance->meta;
115 } else {
116 $meta = $class->meta;
117 }
118 return ( $meta, $is_role, $instance );
119 }
120
121 sub load_class {
122 my ( $self, $class ) = @_;
123 return if $loaded_class->{$class}++;
124 eval {
125 Class::MOP::load_class($class)
126 };
127 warn $@ if $@; # && $@ !~ m/role/;
128 warn "# load_class $class" if $self->debug && $loaded_class->{$class} == 1;
129 }
130
131 sub load_all_classes {
132 my $self = shift;
133 warn "# loaded_class = ",dump( $loaded_class ) if $self->debug;
134 $self->load_class( $_ ) foreach ( $self->classes );
135 $loaded_class;
136 }
137
138 =head2 class_methods
139
140 my @all_methods = $o->class_methods( $class );
141
142 my $class_method = $o->class_methods( $class );
143 if ( $class_method->{ $method } ) {
144 # $class has $method
145 }
146
147 =cut
148
149 sub class_methods {
150 my ( $self, $class ) = @_;
151
152 confess "need class" unless $class;
153 if ( ! $class->can('meta') ) {
154 warn "# $class doesn't have meta (isn't Moose class)" if $self->debug;
155 return;
156 }
157 my $meta = $class->meta;
158
159 my $attr;
160 my $methods;
161 $attr->{$_}++ foreach $meta->get_attribute_list;
162 my @methods = map { $methods->{$_}++; $_ } grep { ! defined($attr->{$_}) && $_ ne 'meta' } $meta->get_method_list;
163 warn "# methods = ",dump( @methods ) if $self->debug;
164
165 return @methods if wantarray;
166 return $methods;
167 }
168
169 =head2 class_runnable
170
171 my @runnable_methods = $o->class_runnable( $class );
172
173 =cut
174
175 sub class_runnable {
176 my ( $self, $class ) = @_;
177 my @methods = grep { m{^as_} || m{_as_} } $self->class_methods( $class );
178 return @methods if wantarray;
179 return \@methods;
180 }
181
182 sub class_inputs {
183 my ( $self, $class ) = @_;
184 my @inputs = grep { m{^(markup/as_data/as_sponge)$} } $self->class_methods( $class );
185 return @inputs if wantarray;
186 return \@inputs;
187 }
188
189 =head2 new_frey_class
190
191 my $instance = $o->new_frey_class( $class, $params );
192
193 This will apply L<Moose::Role> on the fly to provide accessors for
194 C<data> and C<sponge> in form of C<as_*>
195
196 See L<http://www.perlmonks.org/?node_id=602389>
197
198 It is used by L<Frey::Run> and L<Frey::Pipe> to create objects
199
200 =cut
201
202 {
203 package Frey::Role::as_data;
204 use Moose::Role;
205
206 sub as_data {
207 my ($self) = @_;
208 $self->data;
209 }
210
211 package Frey::Role::as_sponge;
212 use Moose::Role;
213 sub as_sponge {
214 my ($self) = @_;
215 $self->sponge;
216 }
217 }
218
219 our $syntax_checked_last;
220
221 sub new_frey_class {
222 my ( $self, $class, $params ) = @_;
223 my $instance;
224
225 my $path = $self->class_path( $class );
226 if ( $syntax_checked_last->{$class} != -C $path ) {
227 my $syntax = `perl -Ilib -wc $path 2>&1`;
228 warn "# syntax: $syntax";
229 $syntax_checked_last->{$class} = -C $class;
230 }
231
232 if ( $class->meta->isa('Moose::Meta::Role') ) {
233 $instance = Frey->new;
234 Frey::Web->meta->apply( $instance );
235 warn "new_frey_class $class role with Frey::Web";
236 } else {
237 if ( $self->can('request_url') ) {
238 $params->{request_url} = $self->request_url;
239 } else {
240 warn "## $self doesn't have request_url";
241 }
242 $instance = $class->new( %$params ) or confess "can't $class->new".dump( %$params );
243 warn "new_frey_class $class";
244 }
245
246 if ( $instance->can('data') && ! $instance->can('as_data') ) {
247 Frey::Role::as_data->meta->apply( $instance );
248 warn "# apply as_data role to $class";
249 }
250 if ( $instance->can('sponge') && ! $instance->can('as_sponge') ) {
251 Frey::Role::as_sponge->meta->apply( $instance );
252 warn "# apply as_sponge role to $class";
253 }
254
255 if ( ! $instance->can('add_status') ) {
256 Frey::Web->meta->apply( $instance );
257 warn "# apply Frey::Web role to $class";
258 }
259
260 $self->add_status({ $class => $params });
261 return $instance;
262 }
263
264 1;

  ViewVC Help
Powered by ViewVC 1.1.26