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 s/\.pm$//;
                my @a = split(m!/!,$_);
                my $class = join('::', @a[ 1 .. $#a ]);
                warn ">> $_ ",dump( @a ), " >> $class\n" if $self->debug;
                $class_path->{ $class } = "$_.pm";
        } }, '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 ) = $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);

        if ( ! $class->can('meta') ) {
                my $instance = Moose::Meta::Class->create_anon_class;
                warn "class $class isn't Moose, faking anon class" if $self->debug;
                return ( $instance, 0 );
        }

        my $meta = $class->meta;
        my $is_role = 0;

        if($class->meta->isa('Moose::Meta::Role')){
                $is_role = 1;
                my $instance = Moose::Meta::Class->create_anon_class;
                warn "# apply $class on $instance";
                $class->meta->apply( $instance );
                die $@ if $@;
                $meta = $instance->meta;
        }
        return ( $meta, $is_role );
}

sub load_class {
        my ( $self, $class ) = @_;
        eval {
                Class::MOP::load_class($class) if ! $loaded_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;
}

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
12			use Data::Dump qw/dump/;
13			use File::Find;
14
15	dpavlin	308	our $class_path;
16	dpavlin	112	our @classes;
17	dpavlin	100
18	dpavlin	308	=head2 classes
19
20	dpavlin	382	Return all local classes by reading from disk
21
22	dpavlin	308	my @classes = $o->classes;
23
24			=cut
25
26	dpavlin	101	sub classes {
27			my $self = shift;
28	dpavlin	112	return @classes if @classes;
29	dpavlin	101
30			# FIXME there must be better way to do this in Moose style
31			finddepth({ no_chdir => 1, wanted => sub {
32			return unless s/\.pm$//;
33			my @a = split(m!/!,$_);
34	dpavlin	308	my $class = join('::', @a[ 1 .. $#a ]);
35			warn ">> $_ ",dump( @a ), " >> $class\n" if $self->debug;
36			$class_path->{ $class } = "$_.pm";
37	dpavlin	101	} }, 'lib');
38	dpavlin	308	warn "## class_path = ",dump( $class_path ) if $self->debug;
39	dpavlin	101
40	dpavlin	308	@classes = sort keys %$class_path;
41	dpavlin	101	}
42
43	dpavlin	308	=head2 class_path
44
45	dpavlin	382	Return any local or loaded class
46
47	dpavlin	308	$path = $o->class_path( $class );
48
49			=cut
50
51			sub class_path {
52			my ( $self, $class ) = @_;
53			$self->classes unless $class_path;
54	dpavlin	382	if ( ! defined $class_path->{$class} ) {
55			my $path = $class;
56			$path =~ s{::}{/}g;
57			$path .= '.pm';
58			$path = $INC{$path};
59			warn "# $class from INC $path";
60	dpavlin	404	$class_path->{$class} = $path \|\| confess "can't find path for $class";
61	dpavlin	382	}
62	dpavlin	308	return $class_path->{$class};
63	dpavlin	101	}
64
65	dpavlin	308	=head2 loaded_classes
66	dpavlin	100
67	dpavlin	308	my $available = $o->loaded_classes;
68			$available->{'Frey'} # true
69	dpavlin	100
70			=cut
71
72	dpavlin	308	our $loaded_class;
73			sub loaded_classes { $loaded_class };
74	dpavlin	100
75	dpavlin	308	=head2 class_meta
76	dpavlin	100
77	dpavlin	308	my ( $meta, $is_role ) = $o->class_meta( 'Some::Class' );
78
79			=cut
80
81			sub class_meta {
82			my ( $self, $class ) = @_;
83
84			$class \|\|= $self->class if $self->can('class');
85			warn "# class_meta $class";
86
87			$self->load_class($class);
88
89			if ( ! $class->can('meta') ) {
90			my $instance = Moose::Meta::Class->create_anon_class;
91	dpavlin	412	warn "class $class isn't Moose, faking anon class" if $self->debug;
92	dpavlin	308	return ( $instance, 0 );
93	dpavlin	101	}
94
95	dpavlin	416	my $meta = $class->meta;
96	dpavlin	137	my $is_role = 0;
97	dpavlin	100
98	dpavlin	308	if($class->meta->isa('Moose::Meta::Role')){
99	dpavlin	100	$is_role = 1;
100	dpavlin	416	my $instance = Moose::Meta::Class->create_anon_class;
101			warn "# apply $class on $instance";
102	dpavlin	308	$class->meta->apply( $instance );
103	dpavlin	137	die $@ if $@;
104	dpavlin	416	$meta = $instance->meta;
105	dpavlin	100	}
106	dpavlin	308	return ( $meta, $is_role );
107	dpavlin	100	}
108
109	dpavlin	308	sub load_class {
110			my ( $self, $class ) = @_;
111			eval {
112			Class::MOP::load_class($class) if ! $loaded_class->{$class}++;
113			};
114			warn $@ if $@; # && $@ !~ m/role/;
115	dpavlin	320	warn "# load_class $class" if $self->debug && $loaded_class->{$class} == 1;
116	dpavlin	308	}
117
118	dpavlin	101	sub load_all_classes {
119			my $self = shift;
120	dpavlin	320	warn "# loaded_class = ",dump( $loaded_class ) if $self->debug;
121	dpavlin	308	$self->load_class( $_ ) foreach ( $self->classes );
122			$loaded_class;
123	dpavlin	101	}
124	dpavlin	100
125	dpavlin	408	=head2 class_methods
126
127	dpavlin	409	my @all_methods = $o->class_methods( $class );
128	dpavlin	408
129	dpavlin	409	my $class_method = $o->class_methods( $class );
130			if ( $class_method->{ $method } ) {
131			# $class has $method
132			}
133
134	dpavlin	408	=cut
135
136			sub class_methods {
137			my ( $self, $class ) = @_;
138
139			confess "need class" unless $class;
140			if ( ! $class->can('meta') ) {
141	dpavlin	411	warn "$class doesn't have meta (isn't Moose class)" if $self->debug;
142	dpavlin	408	return;
143			}
144			my $meta = $class->meta;
145
146			my $attr;
147	dpavlin	409	my $methods;
148	dpavlin	408	$attr->{$_}++ foreach $meta->get_attribute_list;
149	dpavlin	409	my @methods = map { $methods->{$_}++; $_ } grep { ! defined($attr->{$_}) && $_ ne 'meta' } $meta->get_method_list;
150	dpavlin	408	warn "# methods = ",dump( @methods ) if $self->debug;
151
152	dpavlin	409	return @methods if wantarray;
153			return $methods;
154	dpavlin	408	}
155
156	dpavlin	100	1;