This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add Module::Pluggable to the core
[perl5.git] / lib / Module / Pluggable / Object.pm
1 package Module::Pluggable::Object;
2
3 use strict;
4 use File::Find ();
5 use File::Basename;
6 use File::Spec::Functions qw(splitdir catdir abs2rel);
7 use Carp qw(croak carp);
8 use Devel::InnerPackage;
9 use Data::Dumper;
10
11 sub new {
12     my $class = shift;
13     my %opts  = @_;
14
15     return bless \%opts, $class;
16
17 }
18
19
20 sub plugins {
21         my $self = shift;
22
23         # override 'require'
24         $self->{'require'} = 1 if $self->{'inner'};
25
26         my $filename   = $self->{'filename'};
27         my $pkg        = $self->{'package'};
28
29         # automatically turn a scalar search path or namespace into a arrayref
30         for (qw(search_path search_dirs)) {
31             $self->{$_} = [ $self->{$_} ] if exists $self->{$_} && !ref($self->{$_});
32         }
33
34
35
36
37         # default search path is '<Module>::<Name>::Plugin'
38         $self->{'search_path'} = ["${pkg}::Plugin"] unless $self->{'search_path'}; 
39
40
41         #my %opts = %$self;
42
43
44         # check to see if we're running under test
45         my @SEARCHDIR = exists $INC{"blib.pm"} && $filename =~ m!(^|/)blib/! ? grep {/blib/} @INC : @INC;
46
47         # add any search_dir params
48         unshift @SEARCHDIR, @{$self->{'search_dirs'}} if defined $self->{'search_dirs'};
49
50
51         my @plugins = $self->search_directories(@SEARCHDIR);
52
53         # push @plugins, map { print STDERR "$_\n"; $_->require } list_packages($_) for (@{$self->{'search_path'}});
54         
55         # return blank unless we've found anything
56         return () unless @plugins;
57
58
59         # exceptions
60         my %only;   
61         my %except; 
62         my $only;
63         my $except;
64
65         if (defined $self->{'only'}) {
66             if (ref($self->{'only'}) eq 'ARRAY') {
67                 %only   = map { $_ => 1 } @{$self->{'only'}};
68             } elsif (ref($self->{'only'}) eq 'Regexp') {
69                 $only = $self->{'only'}
70             } elsif (ref($self->{'only'}) eq '') {
71                 $only{$self->{'only'}} = 1;
72             }
73         }
74         
75
76         if (defined $self->{'except'}) {
77             if (ref($self->{'except'}) eq 'ARRAY') {
78                 %except   = map { $_ => 1 } @{$self->{'except'}};
79             } elsif (ref($self->{'except'}) eq 'Regexp') {
80                 $except = $self->{'except'}
81             } elsif (ref($self->{'except'}) eq '') {
82                 $except{$self->{'except'}} = 1;
83             }
84         }
85
86
87         # remove duplicates
88         # probably not necessary but hey ho
89         my %plugins;
90         for(@plugins) {
91             next if (keys %only   && !$only{$_}     );
92             next unless (!defined $only || m!$only! );
93
94             next if (keys %except &&  $except{$_}   );
95             next if (defined $except &&  m!$except! );
96             $plugins{$_} = 1;
97         }
98
99         # are we instantiating or requring?
100         if (defined $self->{'instantiate'}) {
101             my $method = $self->{'instantiate'};
102             return map { ($_->can($method)) ? $_->$method(@_) : () } keys %plugins;
103         } else { 
104             # no? just return the names
105             return keys %plugins;
106         }
107
108
109 }
110
111 sub search_directories {
112     my $self      = shift;
113     my @SEARCHDIR = @_;
114
115     my @plugins;
116     # go through our @INC
117     foreach my $dir (@SEARCHDIR) {
118         push @plugins, $self->search_paths($dir);
119     }
120
121     return @plugins;
122 }
123
124
125 sub search_paths {
126     my $self = shift;
127     my $dir  = shift;
128     my @plugins;
129
130     my $file_regex = $self->{'file_regex'} || qr/\.pm$/;
131
132
133     # and each directory in our search path
134     foreach my $searchpath (@{$self->{'search_path'}}) {
135         # create the search directory in a cross platform goodness way
136         my $sp = catdir($dir, (split /::/, $searchpath));
137
138         # if it doesn't exist or it's not a dir then skip it
139         next unless ( -e $sp && -d _ ); # Use the cached stat the second time
140
141         my @files = $self->find_files($sp);
142
143         # foreach one we've found 
144         foreach my $file (@files) {
145             # untaint the file; accept .pm only
146             next unless ($file) = ($file =~ /(.*$file_regex)$/); 
147             # parse the file to get the name
148             my ($name, $directory) = fileparse($file, $file_regex);
149
150             $directory = abs2rel($directory, $sp);
151             # then create the class name in a cross platform way
152             $directory =~ s/^[a-z]://i if($^O =~ /MSWin32|dos/);       # remove volume
153             if ($directory) {
154                 ($directory) = ($directory =~ /(.*)/);
155             } else {
156                 $directory = "";
157             }
158             my $plugin = join "::", splitdir catdir($searchpath, $directory, $name);
159
160             next unless $plugin =~ m!(?:[a-z\d]+)[a-z\d]!i;
161
162             my $err = eval { $self->handle_finding_plugin($plugin) };
163             carp "Couldn't require $plugin : $err" if $err;
164              
165             push @plugins, $plugin;
166         }
167
168         # now add stuff that may have been in package
169         # NOTE we should probably use all the stuff we've been given already
170         # but then we can't unload it :(
171         push @plugins, $self->handle_innerpackages($searchpath) unless (exists $self->{inner} && !$self->{inner});
172     } # foreach $searchpath
173
174     return @plugins;
175 }
176
177 sub handle_finding_plugin {
178     my $self   = shift;
179     my $plugin = shift;
180
181     return unless (defined $self->{'instantiate'} || $self->{'require'}); 
182     $self->_require($plugin);
183 }
184
185 sub find_files {
186     my $self         = shift;
187     my $search_path  = shift;
188     my $file_regex   = $self->{'file_regex'} || qr/\.pm$/;
189
190
191     # find all the .pm files in it
192     # this isn't perfect and won't find multiple plugins per file
193     #my $cwd = Cwd::getcwd;
194     my @files = ();
195     { # for the benefit of perl 5.6.1's Find, localize topic
196         local $_;
197         File::Find::find( { no_chdir => 1, 
198                            wanted => sub { 
199                              # Inlined from File::Find::Rule C< name => '*.pm' >
200                              return unless $File::Find::name =~ /$file_regex/;
201                              (my $path = $File::Find::name) =~ s#^\\./##;
202                              push @files, $path;
203                            }
204                       }, $search_path );
205     }
206     #chdir $cwd;
207     return @files;
208
209 }
210
211 sub handle_innerpackages {
212     my $self = shift;
213     my $path = shift;
214     my @plugins;
215
216
217     foreach my $plugin (Devel::InnerPackage::list_packages($path)) {
218         my $err = eval { $self->handle_finding_plugin($plugin) };
219         #next if $err;
220         #next unless $INC{$plugin};
221         push @plugins, $plugin;
222     }
223     return @plugins;
224
225 }
226
227
228 sub _require {
229     my $self = shift;
230     my $pack = shift;
231     eval "CORE::require $pack";
232     return $@;
233 }
234
235
236 1;
237
238 =pod
239
240 =head1 NAME
241
242 Module::Pluggable::Object - automatically give your module the ability to have plugins
243
244 =head1 SYNOPSIS
245
246
247 Simple use Module::Pluggable -
248
249     package MyClass;
250     use Module::Pluggable::Object;
251     
252     my $finder = Module::Pluggable::Object->new(%opts);
253     print "My plugins are: ".join(", ", $finder->plugins)."\n";
254
255 =head1 DESCRIPTION
256
257 Provides a simple but, hopefully, extensible way of having 'plugins' for 
258 your module. Obviously this isn't going to be the be all and end all of
259 solutions but it works for me.
260
261 Essentially all it does is export a method into your namespace that 
262 looks through a search path for .pm files and turn those into class names. 
263
264 Optionally it instantiates those classes for you.
265
266 =head1 AUTHOR
267
268 Simon Wistow <simon@thegestalt.org>
269
270 =head1 COPYING
271
272 Copyright, 2006 Simon Wistow
273
274 Distributed under the same terms as Perl itself.
275
276 =head1 BUGS
277
278 None known.
279
280 =head1 SEE ALSO
281
282 L<Module::Pluggable>
283
284 =cut 
285