/[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!

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

Parent Directory | Revision Log | View Patch Patch

-revision 308 by dpavlin,
Wed Nov  5 19:13:01 2008 UTC
+revision 519 by dpavlin,
Tue Nov 25 17:15:18 2008 UTC
 Line 17 
 our @classes;
  =head2 classes
+ Return all local classes by reading from disk
    my @classes = $o->classes;
  =cut
-Line 27 
 sub classes {
+Line 29 
 sub classes {
          # FIXME there must be better way to do this in Moose style
          finddepth({ no_chdir => 1, wanted => sub {
-                 return unless s/\.pm$//;
+                 return unless m{\.pm$};
-                 my @a = split(m!/!,$_);
+                 my $class = $_;
-                 my $class = join('::', @a[ 1 .. $#a ]);
+                 $class =~ s{^lib/}{};
-                 warn ">> $_ ",dump( @a ), " >> $class\n" if $self->debug;
+                 $class =~ s{\.pm$}{};
-                 $class_path->{ $class } = "$_.pm";
+                 $class =~ s{/}{::}g;
+                 $class_path->{ $class } = $_;
          } }, 'lib');
          warn "## class_path = ",dump( $class_path ) if $self->debug;
-Line 40 
 sub classes {
+Line 43 
 sub classes {
  =head2 class_path
+ Return any local or loaded class
    $path = $o->class_path( $class );
  =cut
-Line 47 
 sub classes {
+Line 52 
 sub classes {
  sub class_path {
          my ( $self, $class ) = @_;
          $self->classes unless $class_path;
-         confess "can't find path for class $class" unless defined $class_path->{$class};
+         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};
  }
-Line 63 
 sub loaded_classes { $loaded_class };
+Line 75 
 sub loaded_classes { $loaded_class };
  =head2 class_meta
-   my ( $meta, $is_role ) = $o->class_meta( 'Some::Class' );
+   my ( $meta, $is_role, $instance ) = $o->class_meta( 'Some::Class' );
  =cut
-Line 75 
 sub class_meta {
+Line 87 
 sub class_meta {
          $self->load_class($class);
-         if ( ! $class->can('meta') ) {
-                 my $instance = Moose::Meta::Class->create_anon_class;
-                 warn "class $class isn't Moose, faking anon class";
-                 return ( $instance, 0 );
-         }
          my $meta;
          my $is_role = 0;
          my $instance;
-         if($class->meta->isa('Moose::Meta::Role')){
+         if ( ! $class->can('meta') ) {
-                 $is_role = 1;
                  $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;
-                 die $@ if $@;
          } else {
                  $meta = $class->meta;
          }
-         return ( $meta, $is_role );
+         return ( $meta, $is_role, $instance );
  }
  sub load_class {
          my ( $self, $class ) = @_;
+         return if $loaded_class->{$class}++;
          eval {
-                 Class::MOP::load_class($class) if ! $loaded_class->{$class}++;
+                 Class::MOP::load_class($class)
          };
          warn $@ if $@; # && $@ !~ m/role/;
-         warn "# load_class $class" if $loaded_class->{$class} == 1;
+         warn "# load_class $class" if $self->debug && $loaded_class->{$class} == 1;
  }
  sub load_all_classes {
          my $self = shift;
-         warn "# loaded_class = ",dump( $loaded_class );
+         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;
+ }
 ;

 Legend:



Removed from v.308
 


changed lines


 
Added in v.519
 Legend:



Removed from v.308
 


changed lines


 
Added in v.519
-Removed from v.308
+Added in v.519

	ViewVC Help
Powered by ViewVC 1.1.26