1package Module::Pluggable::Fast;
2
3use strict;
4use vars '$VERSION';
5use UNIVERSAL::require;
6use Carp qw/croak carp/;
7use File::Find ();
8use File::Basename;
9use File::Spec::Functions qw/splitdir catdir abs2rel/;
10
11$VERSION = '0.19';
12
13=head1 NAME
14
15Module::Pluggable::Fast - Fast plugins with instantiation
16
17=head1 SYNOPSIS
18
19    package MyClass;
20    use Module::Pluggable::Fast
21      name   => 'components',
22      search => [ qw/MyClass::Model MyClass::View MyClass::Controller/ ];
23
24    package MyOtherClass;
25    use MyClass;
26    my @components = MyClass->components;
27
28=head1 DESCRIPTION
29
30Similar to C<Module::Pluggable> but instantiates plugins as soon as they're
31found, useful for code generators like C<Class::DBI::Loader>.
32
33=head2 OPTIONS
34
35=head3 name
36
37Name for the exported method.
38Defaults to plugins.
39
40=head3 require
41
42If true, only require plugins.
43
44=head3 callback
45
46Codref to be called instead of the default instantiate callback.
47
48=head3 search
49
50Arrayref containing a list of namespaces to search for plugins.
51Defaults to the ::Plugin:: namespace of the calling class.
52
53=cut 
54
55sub import {
56    my ( $class, %args ) = @_;
57    my $caller = caller;
58    no strict 'refs';
59    *{ "$caller\::" . ( $args{name} || 'plugins' ) } = sub {
60        my $self = shift;
61        $args{search}   ||= ["$caller\::Plugin"];
62        $args{require}  ||= 0;
63        $args{callback} ||= sub {
64            my $plugin = shift;
65            my $obj    = $plugin;
66            eval { $obj = $plugin->new(@_) };
67            carp qq/Couldn't instantiate "$plugin", "$@"/ if $@;
68            return $obj;
69        };
70
71        my %plugins;
72        foreach my $dir ( exists $INC{'blib.pm'} ? grep { /blib/ } @INC : @INC )
73        {
74            foreach my $searchpath ( @{ $args{search} } ) {
75                my $sp = catdir( $dir, ( split /::/, $searchpath ) );
76                next unless ( -e $sp && -d $sp );
77                foreach my $file ( _find_packages($sp) ) {
78                    my ( $name, $directory ) = fileparse $file, qr/\.pm/;
79                    $directory = abs2rel $directory, $sp;
80                    my $plugin = join '::', splitdir catdir $searchpath,
81                      $directory, $name;
82                    $plugin->require;
83                    my $error = $UNIVERSAL::require::ERROR;
84                    die qq/Couldn't load "$plugin", "$error"/ if $error;
85
86                    unless ( $plugins{$plugin} ) {
87                        $plugins{$plugin} =
88                            $args{require}
89                          ? $plugin
90                          : $args{callback}->( $plugin, @_ );
91                    }
92
93                    for my $class ( _list_packages($plugin) ) {
94                        next if $plugins{$class};
95                        $plugins{$class} =
96                            $args{require}
97                          ? $class
98                          : $args{callback}->( $class, @_ );
99                    }
100                }
101            }
102        }
103        return values %plugins;
104    };
105}
106
107sub _find_packages {
108    my $search = shift;
109
110    my @files = ();
111
112    my $wanted = sub {
113        my $path = $File::Find::name;
114        return unless $path =~ /\w+\.pm$/;
115        return unless $path =~ /\A(.+)\z/;
116        $path = $1;     # untaint
117
118        # don't include symbolig links pointing into nowhere
119        # (e.g. emacs lock-files)
120        return if -l $path && !-e $path;
121        $path =~ s#^\\./##;
122        push @files, $path;
123    };
124
125    File::Find::find( { no_chdir => 1, wanted => $wanted }, $search );
126
127    return @files;
128}
129
130sub _list_packages {
131    my $class = shift;
132    $class .= '::' unless $class =~ m!::$!;
133    no strict 'refs';
134    my @classes;
135    for my $subclass ( grep !/^main::$/, grep /::$/, keys %$class ) {
136        $subclass =~ s!::$!!;
137        next if $subclass =~ /^::/;
138        push @classes, "$class$subclass";
139        push @classes, _list_packages("$class$subclass");
140    }
141    return @classes;
142}
143
144=head1 AUTHOR
145
146Sebastian Riedel, C<sri@cpan.org>
147
148=head1 COPYRIGHT
149
150This program is free software, you can redistribute it and/or modify it under
151the same terms as Perl itself.
152
153=head1 SEE ALSO
154
155L<Module::Pluggable>
156
157=cut
158
1591;
160