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

package Module::Pluggable::Object;

$VERSION = '3.5_01';

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;

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