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