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
CommitLineData
3f7169a2
RGS
1package Module::Pluggable::Object;
2
bc767658
RGS
3$VERSION = '3.5_01';
4
3f7169a2
RGS
5use strict;
6use File::Find ();
7use File::Basename;
8f75121c 8use File::Spec::Functions qw(splitdir catdir curdir catfile abs2rel);
3f7169a2
RGS
9use Carp qw(croak carp);
10use Devel::InnerPackage;
11use Data::Dumper;
12
13sub new {
14 my $class = shift;
15 my %opts = @_;
16
17 return bless \%opts, $class;
18
19}
20
21
22sub 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
113sub 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
127sub 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
8f75121c 150 my ($name, $directory, $suffix) = fileparse($file, $file_regex);
3f7169a2
RGS
151
152 $directory = abs2rel($directory, $sp);
8f75121c
CB
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
3f7169a2
RGS
176 # then create the class name in a cross platform way
177 $directory =~ s/^[a-z]://i if($^O =~ /MSWin32|dos/); # remove volume
8f75121c 178 my @dirs = ();
3f7169a2
RGS
179 if ($directory) {
180 ($directory) = ($directory =~ /(.*)/);
8f75121c
CB
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 }
3f7169a2
RGS
188 } else {
189 $directory = "";
190 }
8f75121c 191 my $plugin = join '::', $searchpath, @dirs, $name;
3f7169a2
RGS
192
193 next unless $plugin =~ m!(?:[a-z\d]+)[a-z\d]!i;
194
2de60a54 195 my $err = $self->handle_finding_plugin($plugin);
3f7169a2
RGS
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
210sub 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
218sub 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
244sub handle_innerpackages {
245 my $self = shift;
246 my $path = shift;
247 my @plugins;
248
249
250 foreach my $plugin (Devel::InnerPackage::list_packages($path)) {
2de60a54 251 my $err = $self->handle_finding_plugin($plugin);
3f7169a2
RGS
252 #next if $err;
253 #next unless $INC{$plugin};
254 push @plugins, $plugin;
255 }
256 return @plugins;
257
258}
259
260
261sub _require {
262 my $self = shift;
263 my $pack = shift;
2de60a54 264 local $@;
3f7169a2
RGS
265 eval "CORE::require $pack";
266 return $@;
267}
268
269
2701;
271
272=pod
273
274=head1 NAME
275
276Module::Pluggable::Object - automatically give your module the ability to have plugins
277
278=head1 SYNOPSIS
279
280
281Simple 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
291Provides a simple but, hopefully, extensible way of having 'plugins' for
292your module. Obviously this isn't going to be the be all and end all of
293solutions but it works for me.
294
295Essentially all it does is export a method into your namespace that
296looks through a search path for .pm files and turn those into class names.
297
298Optionally it instantiates those classes for you.
299
300=head1 AUTHOR
301
302Simon Wistow <simon@thegestalt.org>
303
304=head1 COPYING
305
306Copyright, 2006 Simon Wistow
307
308Distributed under the same terms as Perl itself.
309
310=head1 BUGS
311
312None known.
313
314=head1 SEE ALSO
315
316L<Module::Pluggable>
317
318=cut
319