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