File Coverage

blib/lib/Module/Pluggable/Object.pm
Criterion Covered Total %
statement 214 226 94.6
branch 97 122 79.5
condition 54 63 85.7
subroutine 21 23 91.3
pod 0 8 0.0
total 386 442 87.3


line stmt bran cond sub pod time code
1             package Module::Pluggable::Object;
2              
3 39     39   78547 use strict;
  39         77  
  39         1252  
4 39     39   234 use File::Find ();
  39         73  
  39         688  
5 39     39   215 use File::Basename;
  39         73  
  39         3590  
6 39     39   39171 use File::Spec::Functions qw(splitdir catdir curdir catfile abs2rel);
  39         42533  
  39         4397  
7 39     39   288 use Carp qw(croak carp confess);
  39         103  
  39         2487  
8 39     39   29016 use Devel::InnerPackage;
  39         120  
  39         2429  
9 39     39   223 use vars qw($VERSION);
  39         76  
  39         1941  
10              
11 39     39   203 use if $] > 5.017, 'deprecate';
  39         79  
  39         247  
12              
13             $VERSION = '5.1';
14              
15              
16             sub new {
17 51     51 0 111 my $class = shift;
18 51         226 my %opts = @_;
19              
20 51         261 return bless \%opts, $class;
21              
22             }
23              
24             ### Eugggh, this code smells
25             ### This is what happens when you keep adding patches
26             ### *sigh*
27              
28              
29             sub plugins {
30 72     72 0 154 my $self = shift;
31 72         153 my @args = @_;
32              
33             # override 'require'
34 72 100       514 $self->{'require'} = 1 if $self->{'inner'};
35              
36 72         180 my $filename = $self->{'filename'};
37 72         151 my $pkg = $self->{'package'};
38              
39             # Get the exception params instantiated
40 72         265 $self->_setup_exceptions;
41              
42             # automatically turn a scalar search path or namespace into a arrayref
43 72         179 for (qw(search_path search_dirs)) {
44 144 100 100     849 $self->{$_} = [ $self->{$_} ] if exists $self->{$_} && !ref($self->{$_});
45             }
46              
47             # default search path is '<Module>::<Name>::Plugin'
48 72   100     514 $self->{'search_path'} ||= ["${pkg}::Plugin"];
49              
50             # default error handler
51 72   100 0   634 $self->{'on_require_error'} ||= sub { my ($plugin, $err) = @_; carp "Couldn't require $plugin : $err"; return 0 };
  0         0  
  0         0  
  0         0  
52 72   100 0   684 $self->{'on_instantiate_error'} ||= sub { my ($plugin, $err) = @_; carp "Couldn't instantiate $plugin: $err"; return 0 };
  0         0  
  0         0  
  0         0  
53              
54             # default whether to follow symlinks
55 72 100       378 $self->{'follow_symlinks'} = 1 unless exists $self->{'follow_symlinks'};
56              
57             # check to see if we're running under test
58 72 50 33     1524 my @SEARCHDIR = exists $INC{"blib.pm"} && defined $filename && $filename =~ m!(^|/)blib/! && !$self->{'force_search_all_paths'} ? grep {/blib/} @INC : @INC;
  0         0  
59              
60             # add any search_dir params
61 72 100       386 unshift @SEARCHDIR, @{$self->{'search_dirs'}} if defined $self->{'search_dirs'};
  4         15  
62              
63             # set our @INC up to include and prefer our search_dirs if necessary
64 72         292 my @tmp = @INC;
65 72 100       126 unshift @tmp, @{$self->{'search_dirs'} || []};
  72         608  
66 72 100       278 local @INC = @tmp if defined $self->{'search_dirs'};
67              
68 72         288 my @plugins = $self->search_directories(@SEARCHDIR);
69 72         144 push(@plugins, $self->handle_inc_hooks($_, @SEARCHDIR)) for @{$self->{'search_path'}};
  72         473  
70 72         133 push(@plugins, $self->handle_innerpackages($_)) for @{$self->{'search_path'}};
  72         481  
71            
72             # return blank unless we've found anything
73 72 100       301 return () unless @plugins;
74              
75             # remove duplicates
76             # probably not necessary but hey ho
77 69         147 my %plugins;
78 69         151 for(@plugins) {
79 222 50       471 next unless $self->_is_legit($_);
80 222         564 $plugins{$_} = 1;
81             }
82              
83             # are we instantiating or requiring?
84 69 100       238 if (defined $self->{'instantiate'}) {
85 3         7 my $method = $self->{'instantiate'};
86 3         6 my @objs = ();
87 3         15 foreach my $package (sort keys %plugins) {
88 10 100       132 next unless $package->can($method);
89 2         5 my $obj = eval { $package->$method(@_) };
  2         9  
90 2 50       19 $self->{'on_instantiate_error'}->($package, $@) if $@;
91 2 50       16 push @objs, $obj if $obj;
92             }
93 3         39 return @objs;
94             } else {
95             # no? just return the names
96 66         364 my @objs= sort keys %plugins;
97 66         959 return @objs;
98             }
99             }
100              
101             sub _setup_exceptions {
102 72     72   122 my $self = shift;
103              
104 72         133 my %only;
105             my %except;
106 0         0 my $only;
107 0         0 my $except;
108              
109 72 100       358 if (defined $self->{'only'}) {
110 13 100       63 if (ref($self->{'only'}) eq 'ARRAY') {
    100          
    50          
111 4         7 %only = map { $_ => 1 } @{$self->{'only'}};
  4         17  
  4         7  
112             } elsif (ref($self->{'only'}) eq 'Regexp') {
113 5         12 $only = $self->{'only'}
114             } elsif (ref($self->{'only'}) eq '') {
115 4         9 $only{$self->{'only'}} = 1;
116             }
117             }
118            
119              
120 72 100       249 if (defined $self->{'except'}) {
121 12 100       55 if (ref($self->{'except'}) eq 'ARRAY') {
    100          
    50          
122 4         6 %except = map { $_ => 1 } @{$self->{'except'}};
  4         20  
  4         10  
123             } elsif (ref($self->{'except'}) eq 'Regexp') {
124 4         7 $except = $self->{'except'}
125             } elsif (ref($self->{'except'}) eq '') {
126 4         9 $except{$self->{'except'}} = 1;
127             }
128             }
129 72         241 $self->{_exceptions}->{only_hash} = \%only;
130 72         190 $self->{_exceptions}->{only} = $only;
131 72         171 $self->{_exceptions}->{except_hash} = \%except;
132 72         218 $self->{_exceptions}->{except} = $except;
133            
134             }
135              
136             sub _is_legit {
137 490     490   615 my $self = shift;
138 490         601 my $plugin = shift;
139 490 50       531 my %only = %{$self->{_exceptions}->{only_hash}||{}};
  490         2017  
140 490 50       1862 my %except = %{$self->{_exceptions}->{except_hash}||{}};
  490         1578  
141 490         800 my $only = $self->{_exceptions}->{only};
142 490         737 my $except = $self->{_exceptions}->{except};
143 490         1307 my $depth = () = split '::', $plugin, -1;
144              
145 490 100 100     1619 return 0 if (keys %only && !$only{$plugin} );
146 474 100 100     1393 return 0 unless (!defined $only || $plugin =~ m!$only! );
147              
148 465 100 100     2434 return 0 if (keys %except && $except{$plugin} );
149 457 100 100     3786 return 0 if (defined $except && $plugin =~ m!$except! );
150            
151 453 100 100     1363 return 0 if defined $self->{max_depth} && $depth>$self->{max_depth};
152 452 100 100     1843 return 0 if defined $self->{min_depth} && $depth<$self->{min_depth};
153              
154 449         1654 return 1;
155             }
156              
157             sub search_directories {
158 72     72 0 487 my $self = shift;
159 72         266 my @SEARCHDIR = @_;
160              
161 72         227 my @plugins;
162             # go through our @INC
163 72         157 foreach my $dir (@SEARCHDIR) {
164 720         2143 push @plugins, $self->search_paths($dir);
165             }
166 72         376 return @plugins;
167             }
168              
169              
170             sub search_paths {
171 720     720 0 962 my $self = shift;
172 720         1333 my $dir = shift;
173 720         1067 my @plugins;
174              
175 720   66     4251 my $file_regex = $self->{'file_regex'} || qr/\.pm$/;
176              
177              
178             # and each directory in our search path
179 720         905 foreach my $searchpath (@{$self->{'search_path'}}) {
  720         1503  
180             # create the search directory in a cross platform goodness way
181 730         3837 my $sp = catdir($dir, (split /::/, $searchpath));
182              
183             # if it doesn't exist or it's not a dir then skip it
184 730 100 66     32319 next unless ( -e $sp && -d _ ); # Use the cached stat the second time
185              
186 79         414 my @files = $self->find_files($sp);
187              
188             # foreach one we've found
189 79         215 foreach my $file (@files) {
190             # untaint the file; accept .pm only
191 182 50       2045 next unless ($file) = ($file =~ /(.*$file_regex)$/);
192             # parse the file to get the name
193 182         6525 my ($name, $directory, $suffix) = fileparse($file, $file_regex);
194              
195 182 100 100     948 next if (!$self->{include_editor_junk} && $self->_is_editor_junk($name));
196              
197 181         818 $directory = abs2rel($directory, $sp);
198              
199             # If we have a mixed-case package name, assume case has been preserved
200             # correctly. Otherwise, root through the file to locate the case-preserved
201             # version of the package name.
202 181         15811 my @pkg_dirs = ();
203 181 100 66     1275 if ( $name eq lc($name) || $name eq uc($name) ) {
204 2         12 my $pkg_file = catfile($sp, $directory, "$name$suffix");
205 2 50       86 open PKGFILE, "<$pkg_file" or die "search_paths: Can't open $pkg_file: $!";
206 2         3 my $in_pod = 0;
207 2         31 while ( my $line = <PKGFILE> ) {
208 2 50       7 $in_pod = 1 if $line =~ m/^=\w/;
209 2 50       6 $in_pod = 0 if $line =~ /^=cut/;
210 2 50 33     10 next if ($in_pod || $line =~ /^=cut/); # skip pod text
211 2 50       7 next if $line =~ /^\s*#/; # and comments
212 2 50       52 if ( $line =~ m/^\s*package\s+(.*::)?($name)\s*;/i ) {
213 2 50       14 @pkg_dirs = split /::/, $1 if defined $1;;
214 2         5 $name = $2;
215 2         4 last;
216             }
217             }
218 2         30 close PKGFILE;
219             }
220              
221             # then create the class name in a cross platform way
222 181 50       961 $directory =~ s/^[a-z]://i if($^O =~ /MSWin32|dos/); # remove volume
223 181         283 my @dirs = ();
224 181 50       374 if ($directory) {
225 181         704 ($directory) = ($directory =~ /(.*)/);
226 181 100       597 @dirs = grep(length($_), splitdir($directory))
227             unless $directory eq curdir();
228 181         852 for my $d (reverse @dirs) {
229 42         76 my $pkg_dir = pop @pkg_dirs;
230 42 50       133 last unless defined $pkg_dir;
231 0         0 $d =~ s/\Q$pkg_dir\E/$pkg_dir/i; # Correct case
232             }
233             } else {
234 0         0 $directory = "";
235             }
236 181         460 my $plugin = join '::', $searchpath, @dirs, $name;
237              
238 181 50       765 next unless $plugin =~ m!(?:[a-z\d]+)[a-z\d]*!i;
239              
240 181         551 $self->handle_finding_plugin($plugin, \@plugins)
241             }
242              
243             # now add stuff that may have been in package
244             # NOTE we should probably use all the stuff we've been given already
245             # but then we can't unload it :(
246 79         335 push @plugins, $self->handle_innerpackages($searchpath);
247             } # foreach $searchpath
248              
249 720         2750 return @plugins;
250             }
251              
252             sub _is_editor_junk {
253 179     179   267 my $self = shift;
254 179         271 my $name = shift;
255              
256             # Emacs (and other Unix-y editors) leave temp files ending in a
257             # tilde as a backup.
258 179 50       495 return 1 if $name =~ /~$/;
259             # Emacs makes these files while a buffer is edited but not yet
260             # saved.
261 179 100       720 return 1 if $name =~ /^\.#/;
262             # Vim can leave these files behind if it crashes.
263 178 50       391 return 1 if $name =~ /\.sw[po]$/;
264              
265 178         709 return 0;
266             }
267              
268             sub handle_finding_plugin {
269 268     268 0 358 my $self = shift;
270 268         342 my $plugin = shift;
271 268         369 my $plugins = shift;
272 268   100     922 my $no_req = shift || 0;
273            
274 268 100       1056 return unless $self->_is_legit($plugin);
275 227 100 100     1199 unless (defined $self->{'instantiate'} || $self->{'require'}) {
276 124         216 push @$plugins, $plugin;
277 124         523 return;
278             }
279              
280 103 100 100     263 $self->{before_require}->($plugin) || return if defined $self->{before_require};
281 102 100       255 unless ($no_req) {
282 28         47 my $tmp = $@;
283 28         41 my $res = eval { $self->_require($plugin) };
  28         84  
284 28         56 my $err = $@;
285 28         50 $@ = $tmp;
286 28 100       80 if ($err) {
287 1 50       4 if (defined $self->{on_require_error}) {
288 1 50       5 $self->{on_require_error}->($plugin, $err) || return;
289             } else {
290 0         0 return;
291             }
292             }
293             }
294 101 100 100     260 $self->{after_require}->($plugin) || return if defined $self->{after_require};
295 98         441 push @$plugins, $plugin;
296             }
297              
298             sub find_files {
299 80     80 0 150 my $self = shift;
300 80         149 my $search_path = shift;
301 80   66     653 my $file_regex = $self->{'file_regex'} || qr/\.pm$/;
302              
303              
304             # find all the .pm files in it
305             # this isn't perfect and won't find multiple plugins per file
306             #my $cwd = Cwd::getcwd;
307 80         174 my @files = ();
308             { # for the benefit of perl 5.6.1's Find, localize topic
309 80         110 local $_;
  80         115  
310             File::Find::find( { no_chdir => 1,
311             follow => $self->{'follow_symlinks'},
312             wanted => sub {
313             # Inlined from File::Find::Rule C< name => '*.pm' >
314 315 100   315   16164 return unless $File::Find::name =~ /$file_regex/;
315 185         376 (my $path = $File::Find::name) =~ s#^\\./##;
316 185         7346 push @files, $path;
317             }
318 80         12506 }, $search_path );
319             }
320             #chdir $cwd;
321 80         922 return @files;
322              
323             }
324              
325             sub handle_inc_hooks {
326 73     73 0 219 my $self = shift;
327 73         135 my $path = shift;
328 73         352 my @SEARCHDIR = @_;
329              
330 73         116 my @plugins;
331 73         146 for my $dir ( @SEARCHDIR ) {
332 730 100 66     1878 next unless ref $dir && eval { $dir->can( 'files' ) };
  1         12  
333              
334 1         8 foreach my $plugin ( $dir->files ) {
335 1         8 $plugin =~ s/\.pm$//;
336 1         5 $plugin =~ s{/}{::}g;
337 1 50       19 next unless $plugin =~ m!^${path}::!;
338 1         6 $self->handle_finding_plugin( $plugin, \@plugins );
339             }
340             }
341 73         315 return @plugins;
342             }
343              
344             sub handle_innerpackages {
345 152     152 0 258 my $self = shift;
346 152 100 100     547 return () if (exists $self->{inner} && !$self->{inner});
347              
348 149         214 my $path = shift;
349 149         194 my @plugins;
350              
351 149         580 foreach my $plugin (Devel::InnerPackage::list_packages($path)) {
352 86         263 $self->handle_finding_plugin($plugin, \@plugins, 1);
353             }
354 149         690 return @plugins;
355              
356             }
357              
358              
359             sub _require {
360 28     28   44 my $self = shift;
361 28         44 my $pack = shift;
362 28         2132 eval "CORE::require $pack";
363 28 100       105829 die ($@) if $@;
364 27         86 return 1;
365             }
366              
367              
368             1;
369              
370             =pod
371              
372             =head1 NAME
373              
374             Module::Pluggable::Object - automatically give your module the ability to have plugins
375              
376             =head1 SYNOPSIS
377              
378              
379             Simple use Module::Pluggable -
380              
381             package MyClass;
382             use Module::Pluggable::Object;
383            
384             my $finder = Module::Pluggable::Object->new(%opts);
385             print "My plugins are: ".join(", ", $finder->plugins)."\n";
386              
387             =head1 DESCRIPTION
388              
389             Provides a simple but, hopefully, extensible way of having 'plugins' for
390             your module. Obviously this isn't going to be the be all and end all of
391             solutions but it works for me.
392              
393             Essentially all it does is export a method into your namespace that
394             looks through a search path for .pm files and turn those into class names.
395              
396             Optionally it instantiates those classes for you.
397              
398             This object is wrapped by C<Module::Pluggable>. If you want to do something
399             odd or add non-general special features you're probably best to wrap this
400             and produce your own subclass.
401              
402             =head1 OPTIONS
403              
404             See the C<Module::Pluggable> docs.
405              
406             =head1 AUTHOR
407              
408             Simon Wistow <simon@thegestalt.org>
409              
410             =head1 COPYING
411              
412             Copyright, 2006 Simon Wistow
413              
414             Distributed under the same terms as Perl itself.
415              
416             =head1 BUGS
417              
418             None known.
419              
420             =head1 SEE ALSO
421              
422             L<Module::Pluggable>
423              
424             =cut
425