This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
b8e58ea7080bf9bd30e0ba9277145a3290482695
[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 curdir catfile 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, $suffix) = fileparse($file, $file_regex);
149
150             $directory = abs2rel($directory, $sp);
151
152             # If we have a mixed-case package name, assume case has been preserved
153             # correctly.  Otherwise, root through the file to locate the case-preserved
154             # version of the package name.
155             my @pkg_dirs = ();
156             if ( $name eq lc($name) || $name eq uc($name) ) {
157                 my $pkg_file = catfile($sp, $directory, "$name$suffix");
158                 open PKGFILE, "<$pkg_file" or die "search_paths: Can't open $pkg_file: $!";
159                 my $in_pod = 0;
160                 while ( my $line = <PKGFILE> ) {
161                     $in_pod = 1 if $line =~ m/^=\w/;
162                     $in_pod = 0 if $line =~ /^=cut/;
163                     next if ($in_pod || $line =~ /^=cut/);  # skip pod text
164                     next if $line =~ /^\s*#/;               # and comments
165                     if ( $line =~ m/^\s*package\s+(.*::)?($name)\s*;/i ) {
166                         @pkg_dirs = split /::/, $1;
167                         $name = $2;
168                         last;
169                     }
170                 }
171                 close PKGFILE;
172             }
173
174             # then create the class name in a cross platform way
175             $directory =~ s/^[a-z]://i if($^O =~ /MSWin32|dos/);       # remove volume
176             my @dirs = ();
177             if ($directory) {
178                 ($directory) = ($directory =~ /(.*)/);
179                 @dirs = grep(length($_), splitdir($directory)) 
180                     unless $directory eq curdir();
181                 for my $d (reverse @dirs) {
182                     my $pkg_dir = pop @pkg_dirs; 
183                     last unless defined $pkg_dir;
184                     $d =~ s/\Q$pkg_dir\E/$pkg_dir/i;  # Correct case
185                 }
186             } else {
187                 $directory = "";
188             }
189             my $plugin = join '::', $searchpath, @dirs, $name;
190
191             next unless $plugin =~ m!(?:[a-z\d]+)[a-z\d]!i;
192
193             my $err = $self->handle_finding_plugin($plugin);
194             carp "Couldn't require $plugin : $err" if $err;
195              
196             push @plugins, $plugin;
197         }
198
199         # now add stuff that may have been in package
200         # NOTE we should probably use all the stuff we've been given already
201         # but then we can't unload it :(
202         push @plugins, $self->handle_innerpackages($searchpath) unless (exists $self->{inner} && !$self->{inner});
203     } # foreach $searchpath
204
205     return @plugins;
206 }
207
208 sub handle_finding_plugin {
209     my $self   = shift;
210     my $plugin = shift;
211
212     return unless (defined $self->{'instantiate'} || $self->{'require'}); 
213     $self->_require($plugin);
214 }
215
216 sub find_files {
217     my $self         = shift;
218     my $search_path  = shift;
219     my $file_regex   = $self->{'file_regex'} || qr/\.pm$/;
220
221
222     # find all the .pm files in it
223     # this isn't perfect and won't find multiple plugins per file
224     #my $cwd = Cwd::getcwd;
225     my @files = ();
226     { # for the benefit of perl 5.6.1's Find, localize topic
227         local $_;
228         File::Find::find( { no_chdir => 1, 
229                            wanted => sub { 
230                              # Inlined from File::Find::Rule C< name => '*.pm' >
231                              return unless $File::Find::name =~ /$file_regex/;
232                              (my $path = $File::Find::name) =~ s#^\\./##;
233                              push @files, $path;
234                            }
235                       }, $search_path );
236     }
237     #chdir $cwd;
238     return @files;
239
240 }
241
242 sub handle_innerpackages {
243     my $self = shift;
244     my $path = shift;
245     my @plugins;
246
247
248     foreach my $plugin (Devel::InnerPackage::list_packages($path)) {
249         my $err = $self->handle_finding_plugin($plugin);
250         #next if $err;
251         #next unless $INC{$plugin};
252         push @plugins, $plugin;
253     }
254     return @plugins;
255
256 }
257
258
259 sub _require {
260     my $self = shift;
261     my $pack = shift;
262     local $@;
263     eval "CORE::require $pack";
264     return $@;
265 }
266
267
268 1;
269
270 =pod
271
272 =head1 NAME
273
274 Module::Pluggable::Object - automatically give your module the ability to have plugins
275
276 =head1 SYNOPSIS
277
278
279 Simple use Module::Pluggable -
280
281     package MyClass;
282     use Module::Pluggable::Object;
283     
284     my $finder = Module::Pluggable::Object->new(%opts);
285     print "My plugins are: ".join(", ", $finder->plugins)."\n";
286
287 =head1 DESCRIPTION
288
289 Provides a simple but, hopefully, extensible way of having 'plugins' for 
290 your module. Obviously this isn't going to be the be all and end all of
291 solutions but it works for me.
292
293 Essentially all it does is export a method into your namespace that 
294 looks through a search path for .pm files and turn those into class names. 
295
296 Optionally it instantiates those classes for you.
297
298 =head1 AUTHOR
299
300 Simon Wistow <simon@thegestalt.org>
301
302 =head1 COPYING
303
304 Copyright, 2006 Simon Wistow
305
306 Distributed under the same terms as Perl itself.
307
308 =head1 BUGS
309
310 None known.
311
312 =head1 SEE ALSO
313
314 L<Module::Pluggable>
315
316 =cut 
317