File Coverage

blib/lib/Module/Require.pm

Criterion	Covered	Total	%
statement	6	90	6.6
branch	0	46	0.0
condition	0	16	0.0
subroutine	2	8	25.0
pod	3	3	100.0
total	11	163	6.7

package Module::Require;

use strict;
use vars qw: @ISA @EXPORT_OK $VERSION :;

$VERSION = '0.05';

@ISA = qw[ Exporter ];

# $Id: Require.pm,v 1.1 2004/03/05 16:58:44 jgsmith Exp $

@EXPORT_OK = qw: require_regex require_glob walk_inc :;

sub _walk_inc {
    my $filter = shift;
    my $todo = shift;
    my $prefix = shift;
    my $root = shift;

    my %modules = ( );
    my $dh;
    opendir $dh, "$prefix/$root";
    my(@files) = grep { defined } map &$filter("$root/$_"), grep !/^\./, readdir($dh);
    closedir $dh;
    foreach my $f (@files) {
        next unless $f;
        my $realfilename = "$prefix/$root/$f";
        next if $INC{"$root/$f"};
        if ( -d $realfilename ) {
            @modules{&_walk_inc($filter, $todo, $prefix, "$root/$f")} = ( );
        } elsif( -f $realfilename ) {
            $modules{"$root/$f"} = undef;
            eval { &$todo("$root/$f", $realfilename) and delete $modules{"$root/$f"} };
        }
    }
    return keys %modules;
}

sub walk_inc(;&&$) {
    my $filter = shift;
    $filter ||= sub { return $_ unless /\.pod$/ or /\.pl$/ };

    my $todo = shift;
    $todo ||= sub { require $_[1] and $INC{$_[0]} = $_[1] and 1 };

    my $root = shift;
    $root = "" unless defined $root;

    my %modules = ( );
    foreach my $prefix (@INC) {
        @modules{_walk_inc $filter, $todo, $prefix, $root} = ( );
    }
    return unless defined wantarray;
    return wantarray ? keys %modules : scalar keys %modules;
}

sub require_regex {
    my %modules = ( );
    while(@_) {
        my $file = shift;
        $file =~ s{::}{/}g;
        $file .= ".pm";
        my $fileprefix = "";

        if($file =~ m{^(.*)/([^/]*)$}) {
            $fileprefix = $1;
            $file = $2;
        }

        # $file is guaranteed to not have a `/' in it :)
        my $filter = eval qq"sub { grep m/$file/, readdir \$_[0] }";

        # thanks to `perldoc -f require' for the basic logic here :)
        foreach my $prefix (@INC) {
            my $dh;
            opendir $dh, "$prefix/$fileprefix";
            my @files = &$filter($dh);
            closedir $dh;
            foreach my $f (@files) {
                my $realfilename = "$prefix/$fileprefix/$f";
                next if $INC{$realfilename} || $INC{"$fileprefix/$f"};
                if( -f $realfilename ) {
                    $modules{"$fileprefix/$f"} = undef;
                    eval {
                        $INC{"$fileprefix/$f"} = $realfilename if eval qq"require $realfilename";
			delete $INC{$realfilename};
                    };
                }
            }
        }
        delete @modules{grep m{$fileprefix/$file}, keys %INC} if defined wantarray;
    }
    return unless defined wantarray;
    return wantarray ? keys %modules : scalar keys %modules;
}

sub require_glob {
    my %modules = ( );
    while(@_) {
        my $file = shift;
        $file =~ s{::}{/}g;
        $file .= '\.pm';
        my $fileprefix = "";

        if($file =~ m{^(.*)/([^/]*)$}) {
            $fileprefix = $1;
            $file = $2;
        }

        # thanks to `perldoc -f require' for the basic logic here :)
        foreach my $prefix (@INC) {
            my @files = eval "<$prefix/$fileprefix/$file>";
            foreach my $realfilename (@files) {
                my $f = $realfilename;
                $f =~ s{^$prefix/$fileprefix/}{};
                next if $INC{$realfilename} || $INC{"$fileprefix/$f"};
                if( -f $realfilename ) {
                    $modules{"$fileprefix/$f"} = undef;
                    eval {
                        if(eval { require $realfilename }) {
                            $INC{"$fileprefix/$f"} = $realfilename;
                            delete $modules{"$fileprefix/$f"};
			    delete $INC{$realfilename};
                        }
                    };
                }
            }
        }
    }
    return unless defined wantarray;
    return wantarray ? keys %modules : scalar keys %modules;
}

1;

__END__