[p5sagit/p5-mst-13.2.git] / lib / Module / Pluggable / Object.pm

package Module::Pluggable::Object;

use strict;
use File::Find ();
use File::Basename;
use File::Spec::Functions qw(splitdir catdir curdir catfile abs2rel);
use Carp qw(croak carp);
use Devel::InnerPackage;
use Data::Dumper;
use vars qw($VERSION);

$VERSION = '3.6';


sub new {
    my $class = shift;
    my %opts  = @_;

    return bless \%opts, $class;

}


sub plugins {
        my $self = shift;

        # override 'require'
        $self->{'require'} = 1 if $self->{'inner'};

        my $filename   = $self->{'filename'};
        my $pkg        = $self->{'package'};

        # automatically turn a scalar search path or namespace into a arrayref
        for (qw(search_path search_dirs)) {
            $self->{$_} = [ $self->{$_} ] if exists $self->{$_} && !ref($self->{$_});
        }


        # default search path is '<Module>::<Name>::Plugin'
        $self->{'search_path'} = ["${pkg}::Plugin"] unless $self->{'search_path'}; 


        #my %opts = %$self;


        # check to see if we're running under test
        my @SEARCHDIR = exists $INC{"blib.pm"} && $filename =~ m!(^|/)blib/! ? grep {/blib/} @INC : @INC;

        # add any search_dir params
        unshift @SEARCHDIR, @{$self->{'search_dirs'}} if defined $self->{'search_dirs'};


        my @plugins = $self->search_directories(@SEARCHDIR);

        # push @plugins, map { print STDERR "$_\n"; $_->require } list_packages($_) for (@{$self->{'search_path'}});
        
        # return blank unless we've found anything
        return () unless @plugins;


        # exceptions
        my %only;   
        my %except; 
        my $only;
        my $except;

        if (defined $self->{'only'}) {
            if (ref($self->{'only'}) eq 'ARRAY') {
                %only   = map { $_ => 1 } @{$self->{'only'}};
            } elsif (ref($self->{'only'}) eq 'Regexp') {
                $only = $self->{'only'}
            } elsif (ref($self->{'only'}) eq '') {
                $only{$self->{'only'}} = 1;
            }
        }
        

        if (defined $self->{'except'}) {
            if (ref($self->{'except'}) eq 'ARRAY') {
                %except   = map { $_ => 1 } @{$self->{'except'}};
            } elsif (ref($self->{'except'}) eq 'Regexp') {
                $except = $self->{'except'}
            } elsif (ref($self->{'except'}) eq '') {
                $except{$self->{'except'}} = 1;
            }
        }


        # remove duplicates
        # probably not necessary but hey ho
        my %plugins;
        for(@plugins) {
            next if (keys %only   && !$only{$_}     );
            next unless (!defined $only || m!$only! );

            next if (keys %except &&  $except{$_}   );
            next if (defined $except &&  m!$except! );
            $plugins{$_} = 1;
        }

        # are we instantiating or requring?
        if (defined $self->{'instantiate'}) {
            my $method = $self->{'instantiate'};
            return map { ($_->can($method)) ? $_->$method(@_) : () } keys %plugins;
        } else { 
            # no? just return the names
            return keys %plugins;
        }


}

sub search_directories {
    my $self      = shift;
    my @SEARCHDIR = @_;

    my @plugins;
    # go through our @INC
    foreach my $dir (@SEARCHDIR) {
        push @plugins, $self->search_paths($dir);
    }

    return @plugins;
}


sub search_paths {
    my $self = shift;
    my $dir  = shift;
    my @plugins;

    my $file_regex = $self->{'file_regex'} || qr/\.pm$/;


    # and each directory in our search path
    foreach my $searchpath (@{$self->{'search_path'}}) {
        # create the search directory in a cross platform goodness way
        my $sp = catdir($dir, (split /::/, $searchpath));

        # if it doesn't exist or it's not a dir then skip it
        next unless ( -e $sp && -d _ ); # Use the cached stat the second time

        my @files = $self->find_files($sp);

        # foreach one we've found 
        foreach my $file (@files) {
            # untaint the file; accept .pm only
            next unless ($file) = ($file =~ /(.*$file_regex)$/); 
            # parse the file to get the name
            my ($name, $directory, $suffix) = fileparse($file, $file_regex);

            $directory = abs2rel($directory, $sp);

            # If we have a mixed-case package name, assume case has been preserved
            # correctly.  Otherwise, root through the file to locate the case-preserved
            # version of the package name.
            my @pkg_dirs = ();
            if ( $name eq lc($name) || $name eq uc($name) ) {
                my $pkg_file = catfile($sp, $directory, "$name$suffix");
                open PKGFILE, "<$pkg_file" or die "search_paths: Can't open $pkg_file: $!";
                my $in_pod = 0;
                while ( my $line = <PKGFILE> ) {
                    $in_pod = 1 if $line =~ m/^=\w/;
                    $in_pod = 0 if $line =~ /^=cut/;
                    next if ($in_pod || $line =~ /^=cut/);  # skip pod text
                    next if $line =~ /^\s*#/;               # and comments
                    if ( $line =~ m/^\s*package\s+(.*::)?($name)\s*;/i ) {
                        @pkg_dirs = split /::/, $1;
                        $name = $2;
                        last;
                    }
                }
                close PKGFILE;
            }

            # then create the class name in a cross platform way
            $directory =~ s/^[a-z]://i if($^O =~ /MSWin32|dos/);       # remove volume
            my @dirs = ();
            if ($directory) {
                ($directory) = ($directory =~ /(.*)/);
                @dirs = grep(length($_), splitdir($directory)) 
                    unless $directory eq curdir();
                for my $d (reverse @dirs) {
                    my $pkg_dir = pop @pkg_dirs; 
                    last unless defined $pkg_dir;
                    $d =~ s/\Q$pkg_dir\E/$pkg_dir/i;  # Correct case
                }
            } else {
                $directory = "";
            }
            my $plugin = join '::', $searchpath, @dirs, $name;

            next unless $plugin =~ m!(?:[a-z\d]+)[a-z\d]!i;

            my $err = $self->handle_finding_plugin($plugin);
            carp "Couldn't require $plugin : $err" if $err;
             
            push @plugins, $plugin;
        }

        # now add stuff that may have been in package
        # NOTE we should probably use all the stuff we've been given already
        # but then we can't unload it :(
        push @plugins, $self->handle_innerpackages($searchpath) unless (exists $self->{inner} && !$self->{inner});
    } # foreach $searchpath

    return @plugins;
}

sub handle_finding_plugin {
    my $self   = shift;
    my $plugin = shift;

    return unless (defined $self->{'instantiate'} || $self->{'require'}); 
    $self->_require($plugin);
}

sub find_files {
    my $self         = shift;
    my $search_path  = shift;
    my $file_regex   = $self->{'file_regex'} || qr/\.pm$/;


    # find all the .pm files in it
    # this isn't perfect and won't find multiple plugins per file
    #my $cwd = Cwd::getcwd;
    my @files = ();
    { # for the benefit of perl 5.6.1's Find, localize topic
        local $_;
        File::Find::find( { no_chdir => 1, 
                           wanted => sub { 
                             # Inlined from File::Find::Rule C< name => '*.pm' >
                             return unless $File::Find::name =~ /$file_regex/;
                             (my $path = $File::Find::name) =~ s#^\\./##;
                             push @files, $path;
                           }
                      }, $search_path );
    }
    #chdir $cwd;
    return @files;

}

sub handle_innerpackages {
    my $self = shift;
    my $path = shift;
    my @plugins;


    foreach my $plugin (Devel::InnerPackage::list_packages($path)) {
        my $err = $self->handle_finding_plugin($plugin);
        #next if $err;
        #next unless $INC{$plugin};
        push @plugins, $plugin;
    }
    return @plugins;

}


sub _require {
    my $self = shift;
    my $pack = shift;
    local $@;
    eval "CORE::require $pack";
    return $@;
}


1;

=pod

=head1 NAME

Module::Pluggable::Object - automatically give your module the ability to have plugins

=head1 SYNOPSIS


Simple use Module::Pluggable -

    package MyClass;
    use Module::Pluggable::Object;
    
    my $finder = Module::Pluggable::Object->new(%opts);
    print "My plugins are: ".join(", ", $finder->plugins)."\n";

=head1 DESCRIPTION

Provides a simple but, hopefully, extensible way of having 'plugins' for 
your module. Obviously this isn't going to be the be all and end all of
solutions but it works for me.

Essentially all it does is export a method into your namespace that 
looks through a search path for .pm files and turn those into class names. 

Optionally it instantiates those classes for you.

=head1 AUTHOR

Simon Wistow <simon@thegestalt.org>

=head1 COPYING

Copyright, 2006 Simon Wistow

Distributed under the same terms as Perl itself.

=head1 BUGS

None known.

=head1 SEE ALSO

L<Module::Pluggable>

=cut
Commit	Line	Data
3f7169a2	1	package Module::Pluggable::Object;
	2
	3	use strict;
	4	use File::Find ();
	5	use File::Basename;
8f75121c	6	use File::Spec::Functions qw(splitdir catdir curdir catfile abs2rel);
3f7169a2	7	use Carp qw(croak carp);
	8	use Devel::InnerPackage;
	9	use Data::Dumper;
abcddaf0	10	use vars qw($VERSION);
	11
	12	$VERSION = '3.6';
	13
3f7169a2	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
8f75121c	152	my ($name, $directory, $suffix) = fileparse($file, $file_regex);
3f7169a2	153
3f7169a2	154	$directory = abs2rel($directory, $sp);
8f75121c	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/^\spackage\s+(.::)?($name)\s*;/i ) {
	170	@pkg_dirs = split /::/, $1;
	171	$name = $2;
	172	last;
	173	}
	174	}
	175	close PKGFILE;
	176	}
	177
3f7169a2	178	# then create the class name in a cross platform way
3f7169a2	179	$directory =~ s/^[a-z]://i if($^O =~ /MSWin32\|dos/); # remove volume
8f75121c	180	my @dirs = ();
3f7169a2	181	if ($directory) {
3f7169a2	182	($directory) = ($directory =~ /(.*)/);
8f75121c	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	}
3f7169a2	190	} else {
	191	$directory = "";
	192	}
8f75121c	193	my $plugin = join '::', $searchpath, @dirs, $name;
3f7169a2	194
	195	next unless $plugin =~ m!(?:[a-z\d]+)[a-z\d]!i;
	196
2de60a54	197	my $err = $self->handle_finding_plugin($plugin);
3f7169a2	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)) {
2de60a54	253	my $err = $self->handle_finding_plugin($plugin);
3f7169a2	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;
2de60a54	266	local $@;
3f7169a2	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