[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
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 use vars qw($VERSION); 11 12 $VERSION = '3.6'; 13 14 15 sub new { 16 my $class = shift; 17 my %opts = @_; 18 19 return bless \%opts, $class; 20 21 } 22 23 24 sub plugins { 25 my $self = shift; 26 27 # override 'require' 28 $self->{'require'} = 1 if $self->{'inner'}; 29 30 my $filename = $self->{'filename'}; 31 my $pkg = $self->{'package'}; 32 33 # automatically turn a scalar search path or namespace into a arrayref 34 for (qw(search_path search_dirs)) { 35 $self->{$_} = [ $self->{$_} ] if exists $self->{$_} && !ref($self->{$_}); 36 } 37 38 39 40 41 # default search path is '<Module>::<Name>::Plugin' 42 $self->{'search_path'} = ["$pkg}::Plugin"] unless $self->{'search_path'}; 43 44 45 #my %opts = %$self; 46 47 48 # check to see if we're running under test 49 my @SEARCHDIR = exists $INC{"blib.pm"} && $filename =~ m!(^|/)blib/! ? grep {/blib/} @INC : @INC; 50 51 # add any search_dir params 52 unshift @SEARCHDIR, @{$self->{'search_dirs'}} if defined $self->{'search_dirs'}; 53 54 55 my @plugins = $self->search_directories(@SEARCHDIR); 56 57 # push @plugins, map { print STDERR "$_\n"; $_->require } list_packages($_) for (@{$self->{'search_path'}}); 58 59 # return blank unless we've found anything 60 return () unless @plugins; 61 62 63 # exceptions 64 my %only; 65 my %except; 66 my $only; 67 my $except; 68 69 if (defined $self->{'only'}) { 70 if (ref($self->{'only'}) eq 'ARRAY') { 71 %only = map { $_ => 1 } @{$self->{'only'}}; 72 } elsif (ref($self->{'only'}) eq 'Regexp') { 73 $only = $self->{'only'} 74 } elsif (ref($self->{'only'}) eq '') { 75 $only{$self->{'only'}} = 1; 76 } 77 } 78 79 80 if (defined $self->{'except'}) { 81 if (ref($self->{'except'}) eq 'ARRAY') { 82 %except = map { $_ => 1 } @{$self->{'except'}}; 83 } elsif (ref($self->{'except'}) eq 'Regexp') { 84 $except = $self->{'except'} 85 } elsif (ref($self->{'except'}) eq '') { 86 $except{$self->{'except'}} = 1; 87 } 88 } 89 90 91 # remove duplicates 92 # probably not necessary but hey ho 93 my %plugins; 94 for(@plugins) { 95 next if (keys %only && !$only{$_} ); 96 next unless (!defined $only || m!$only! ); 97 98 next if (keys %except && $except{$_} ); 99 next if (defined $except && m!$except! ); 100 $plugins{$_} = 1; 101 } 102 103 # are we instantiating or requring? 104 if (defined $self->{'instantiate'}) { 105 my $method = $self->{'instantiate'}; 106 return map { ($_->can($method)) ? $_->$method(@_) : () } keys %plugins; 107 } else { 108 # no? just return the names 109 return keys %plugins; 110 } 111 112 113 } 114 115 sub search_directories { 116 my $self = shift; 117 my @SEARCHDIR = @_; 118 119 my @plugins; 120 # go through our @INC 121 foreach my $dir (@SEARCHDIR) { 122 push @plugins, $self->search_paths($dir); 123 } 124 125 return @plugins; 126 } 127 128 129 sub search_paths { 130 my $self = shift; 131 my $dir = shift; 132 my @plugins; 133 134 my $file_regex = $self->{'file_regex'} || qr/\.pm$/; 135 136 137 # and each directory in our search path 138 foreach my $searchpath (@{$self->{'search_path'}}) { 139 # create the search directory in a cross platform goodness way 140 my $sp = catdir($dir, (split /::/, $searchpath)); 141 142 # if it doesn't exist or it's not a dir then skip it 143 next unless ( -e $sp && -d _ ); # Use the cached stat the second time 144 145 my @files = $self->find_files($sp); 146 147 # foreach one we've found 148 foreach my $file (@files) { 149 # untaint the file; accept .pm only 150 next unless ($file) = ($file =~ /(.*$file_regex)$/); 151 # parse the file to get the name 152 my ($name, $directory, $suffix) = fileparse($file, $file_regex); 153 154 $directory = abs2rel($directory, $sp); 155 156 # If we have a mixed-case package name, assume case has been preserved 157 # correctly. Otherwise, root through the file to locate the case-preserved 158 # version of the package name. 159 my @pkg_dirs = (); 160 if ( $name eq lc($name) || $name eq uc($name) ) { 161 my $pkg_file = catfile($sp, $directory, "$name$suffix"); 162 open PKGFILE, "<$pkg_file" or die "search_paths: Can't open $pkg_file: $!"; 163 my $in_pod = 0; 164 while ( my $line = <PKGFILE> ) { 165 $in_pod = 1 if $line =~ m/^=\w/; 166 $in_pod = 0 if $line =~ /^=cut/; 167 next if ($in_pod || $line =~ /^=cut/); # skip pod text 168 next if $line =~ /^\s*#/; # and comments 169 if ( $line =~ m/^\s*package\s+(.*::)?($name)\s*;/i ) { 170 @pkg_dirs = split /::/, $1; 171 $name = $2; 172 last; 173 } 174 } 175 close PKGFILE; 176 } 177 178 # then create the class name in a cross platform way 179 $directory =~ s/^[a-z]://i if($^O =~ /MSWin32|dos/); # remove volume 180 my @dirs = (); 181 if ($directory) { 182 ($directory) = ($directory =~ /(.*)/); 183 @dirs = grep(length($_), splitdir($directory)) 184 unless $directory eq curdir(); 185 for my $d (reverse @dirs) { 186 my $pkg_dir = pop @pkg_dirs; 187 last unless defined $pkg_dir; 188 $d =~ s/\Q$pkg_dir\E/$pkg_dir/i; # Correct case 189 } 190 } else { 191 $directory = ""; 192 } 193 my $plugin = join '::', $searchpath, @dirs, $name; 194 195 next unless $plugin =~ m!(?:[a-z\d]+)[a-z\d]!i; 196 197 my $err = $self->handle_finding_plugin($plugin); 198 carp "Couldn't require $plugin : $err" if $err; 199 200 push @plugins, $plugin; 201 } 202 203 # now add stuff that may have been in package 204 # NOTE we should probably use all the stuff we've been given already 205 # but then we can't unload it :( 206 push @plugins, $self->handle_innerpackages($searchpath) unless (exists $self->{inner} && !$self->{inner}); 207 } # foreach $searchpath 208 209 return @plugins; 210 } 211 212 sub handle_finding_plugin { 213 my $self = shift; 214 my $plugin = shift; 215 216 return unless (defined $self->{'instantiate'} || $self->{'require'}); 217 $self->_require($plugin); 218 } 219 220 sub find_files { 221 my $self = shift; 222 my $search_path = shift; 223 my $file_regex = $self->{'file_regex'} || qr/\.pm$/; 224 225 226 # find all the .pm files in it 227 # this isn't perfect and won't find multiple plugins per file 228 #my $cwd = Cwd::getcwd; 229 my @files = (); 230 { # for the benefit of perl 5.6.1's Find, localize topic 231 local $_; 232 File::Find::find( { no_chdir => 1, 233 wanted => sub { 234 # Inlined from File::Find::Rule C< name => '*.pm' > 235 return unless $File::Find::name =~ /$file_regex/; 236 (my $path = $File::Find::name) =~ s#^\\./##; 237 push @files, $path; 238 } 239 }, $search_path ); 240 } 241 #chdir $cwd; 242 return @files; 243 244 } 245 246 sub handle_innerpackages { 247 my $self = shift; 248 my $path = shift; 249 my @plugins; 250 251 252 foreach my $plugin (Devel::InnerPackage::list_packages($path)) { 253 my $err = $self->handle_finding_plugin($plugin); 254 #next if $err; 255 #next unless $INC{$plugin}; 256 push @plugins, $plugin; 257 } 258 return @plugins; 259 260 } 261 262 263 sub _require { 264 my $self = shift; 265 my $pack = shift; 266 local $@; 267 eval "CORE::require $pack"; 268 return $@; 269 } 270 271 272 1; 273 274 =pod 275 276 =head1 NAME 277 278 Module::Pluggable::Object - automatically give your module the ability to have plugins 279 280 =head1 SYNOPSIS 281 282 283 Simple use Module::Pluggable - 284 285 package MyClass; 286 use Module::Pluggable::Object; 287 288 my $finder = Module::Pluggable::Object->new(%opts); 289 print "My plugins are: ".join(", ", $finder->plugins)."\n"; 290 291 =head1 DESCRIPTION 292 293 Provides a simple but, hopefully, extensible way of having 'plugins' for 294 your module. Obviously this isn't going to be the be all and end all of 295 solutions but it works for me. 296 297 Essentially all it does is export a method into your namespace that 298 looks through a search path for .pm files and turn those into class names. 299 300 Optionally it instantiates those classes for you. 301 302 =head1 AUTHOR 303 304 Simon Wistow <simon@thegestalt.org> 305 306 =head1 COPYING 307 308 Copyright, 2006 Simon Wistow 309 310 Distributed under the same terms as Perl itself. 311 312 =head1 BUGS 313 314 None known. 315 316 =head1 SEE ALSO 317 318 L<Module::Pluggable> 319 320 =cut 321
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |