view release on metacpan or  search on metacpan

inc/Module/Install.pm  view on Meta::CPAN

sub preload {
    my ($self) = @_;

    unless ( $self->{extensions} ) {
        $self->load_extensions(
            "$self->{prefix}/$self->{path}", $self
        );
    }

    my @exts = @{$self->{extensions}};
    unless ( @exts ) {
        my $admin = $self->{admin};
        @exts = $admin->load_all_extensions;
    }

    my %seen;
    foreach my $obj ( @exts ) {
        while (my ($method, $glob) = each %{ref($obj) . '::'}) {
            next unless $obj->can($method);
            next if $method =~ /^_/;
            next if $method eq uc($method);
            $seen{$method}++;
        }
    }

    my $who = $self->_caller;
    foreach my $name ( sort keys %seen ) {
        *{"${who}::$name"} = sub {
            ${"${who}::AUTOLOAD"} = "${who}::$name";
            goto &{"${who}::AUTOLOAD"};
        };
    }
}

sub new {
    my ($class, %args) = @_;

    # ignore the prefix on extension modules built from top level.
    my $base_path = Cwd::abs_path($FindBin::Bin);
    unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
        delete $args{prefix};
    }

    return $args{_self} if $args{_self};

    $args{dispatch} ||= 'Admin';
    $args{prefix}   ||= 'inc';
    $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
    $args{bundle}   ||= 'inc/BUNDLES';
    $args{base}     ||= $base_path;
    $class =~ s/^\Q$args{prefix}\E:://;
    $args{name}     ||= $class;
    $args{version}  ||= $class->VERSION;
    unless ( $args{path} ) {
        $args{path}  = $args{name};
        $args{path}  =~ s!::!/!g;
    }
    $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";

    bless( \%args, $class );
}

sub call {
	my ($self, $method) = @_;
	my $obj = $self->load($method) or return;
        splice(@_, 0, 2, $obj);
	goto &{$obj->can($method)};
}

sub load {
    my ($self, $method) = @_;

    $self->load_extensions(
        "$self->{prefix}/$self->{path}", $self
    ) unless $self->{extensions};

    foreach my $obj (@{$self->{extensions}}) {
        return $obj if $obj->can($method);
    }

    my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE

    my $obj = $admin->load($method, 1);
    push @{$self->{extensions}}, $obj;

    $obj;
}

sub load_extensions {
    my ($self, $path, $top) = @_;

    unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
        unshift @INC, $self->{prefix};
    }

    foreach my $rv ( $self->find_extensions($path) ) {
        my ($file, $pkg) = @{$rv};
        next if $self->{pathnames}{$pkg};

        local $@;
        my $new = eval { require $file; $pkg->can('new') };
        unless ( $new ) {
            warn $@ if $@;
            next;
        }
        $self->{pathnames}{$pkg} = delete $INC{$file};
        push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
    }

    $self->{extensions} ||= [];
}

sub find_extensions {
    my ($self, $path) = @_;

    my @found;
    File::Find::find( sub {