This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
sigtrap.pm (handler_traceback): do not clobber $_
[perl5.git] / lib / Module / Pluggable / Object.pm
CommitLineData
3f7169a2
RGS
1package Module::Pluggable::Object;
2
3use strict;
4use File::Find ();
5use File::Basename;
6use File::Spec::Functions qw(splitdir catdir abs2rel);
7use Carp qw(croak carp);
8use Devel::InnerPackage;
9use Data::Dumper;
10
11sub new {
12 my $class = shift;
13 my %opts = @_;
14
15 return bless \%opts, $class;
16
17}
18
19
20sub 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
111sub 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
125sub 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
2de60a54 162 my $err = $self->handle_finding_plugin($plugin);
3f7169a2
RGS
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
177sub 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
185sub 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
211sub handle_innerpackages {
212 my $self = shift;
213 my $path = shift;
214 my @plugins;
215
216
217 foreach my $plugin (Devel::InnerPackage::list_packages($path)) {
2de60a54 218 my $err = $self->handle_finding_plugin($plugin);
3f7169a2
RGS
219 #next if $err;
220 #next unless $INC{$plugin};
221 push @plugins, $plugin;
222 }
223 return @plugins;
224
225}
226
227
228sub _require {
229 my $self = shift;
230 my $pack = shift;
2de60a54 231 local $@;
3f7169a2
RGS
232 eval "CORE::require $pack";
233 return $@;
234}
235
236
2371;
238
239=pod
240
241=head1 NAME
242
243Module::Pluggable::Object - automatically give your module the ability to have plugins
244
245=head1 SYNOPSIS
246
247
248Simple use Module::Pluggable -
249
250 package MyClass;
251 use Module::Pluggable::Object;
252
253 my $finder = Module::Pluggable::Object->new(%opts);
254 print "My plugins are: ".join(", ", $finder->plugins)."\n";
255
256=head1 DESCRIPTION
257
258Provides a simple but, hopefully, extensible way of having 'plugins' for
259your module. Obviously this isn't going to be the be all and end all of
260solutions but it works for me.
261
262Essentially all it does is export a method into your namespace that
263looks through a search path for .pm files and turn those into class names.
264
265Optionally it instantiates those classes for you.
266
267=head1 AUTHOR
268
269Simon Wistow <simon@thegestalt.org>
270
271=head1 COPYING
272
273Copyright, 2006 Simon Wistow
274
275Distributed under the same terms as Perl itself.
276
277=head1 BUGS
278
279None known.
280
281=head1 SEE ALSO
282
283L<Module::Pluggable>
284
285=cut
286