Commit | Line | Data |
3f7169a2 |
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 | |