view release on metacpan or  search on metacpan

local/lib/perl5/Module/Install/Admin.pm  view on Meta::CPAN

at the author's side.

=item *

Provide a C<Module::Install::purge_self> function for removing included
files under F<inc/>.

=back

=head1 METHODS

=cut

sub import {
	my $class = shift;
	my $self  = $class->new( _top => Module::Install->new, @_ );
	local $^W;
	*{caller(0) . "::AUTOLOAD"} = sub {
		no strict 'vars';
		$AUTOLOAD =~ /([^:]+)$/ or die "Cannot load";
		return if uc($1) eq $1;
		my $obj = $self->load($1) or return;
		unshift @_, $obj;
		goto &{$obj->can($1)};
	};
}

sub new {
	my ($class, %args) = @_;
	return $class->SUPER::new(
		%{$args{_top}}, %args,
		extensions  => undef,
		pathnames   => undef,
	);
}

sub init {
	my $self = shift;
	$self->copy($INC{"$self->{path}.pm"} => $self->{file});

	unless ( grep { $_ eq $self->{prefix} } @INC ) {
		unshift @INC, $self->{prefix};
	}
 	delete $INC{"$self->{path}.pm"};

	local $^W;
	do "$self->{path}.pm";
}

sub copy {
	my ($self, $from, $to) = @_;

	my @parts = split('/', $to);
	File::Path::mkpath([ join('/', @parts[ 0 .. $#parts-1 ])]);

	chomp $to;

	local ($_);
	open my $FROM, "<", $from or die "Can't open $from for input:\n$!";
	open my $TO,   ">", $to   or die "Can't open $to for output:\n$!";
	binmode $FROM;
	binmode $TO;
	print $TO "#line 1\n";

	my $content;
	my $in_pod;

	while ( <$FROM> ) {
		if ( /^=(?:b(?:egin|ack)|head\d|(?:po|en)d|item|(?:ove|fo)r)/ ) {
			$in_pod = 1;
		} elsif ( /^=cut\s*\z/ and $in_pod ) {
			$in_pod = 0;
			print $TO "#line $.\n";
		} elsif ( ! $in_pod ) {
			print $TO $_;
		}
	}

	close $FROM or die "Can't close $from for input:\n$!";
	close $TO   or die "Can't close $to for output:\n$!";

	print "include $to\n";
}

# scan through our target to find
sub load_all_extensions {
	my $self = shift;
	unless ($self->{extensions}) {
		$self->{extensions} = [];
		foreach my $inc (@INC) {
			next if ref($inc) or $inc eq $self->{prefix};
			$self->load_extensions("$inc/$self->{path}", $self->{_top});
		}
	}
	return @{$self->{extensions}};
}

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

	my @extobj;
	foreach my $obj ($self->load_all_extensions) {
		next unless defined &{ref($obj)."::$method"};
		my $is_admin = (ref($obj) =~ /^\Q$self->{name}::$self->{dispatch}::/);
		# Don't ever include admin modules, and vice versa.
		# $copy = 0 if $XXX and $is_admin;
		push @extobj, $obj if $copy xor $is_admin;
	}
	unless ( @extobj ) {
		die "Cannot find an extension with method '$method'";
	}

	# XXX - do we need to reload $obj from the new location?
	my $obj = $self->pick($method, \@extobj);
	$self->copy_package(ref($obj)) if $copy;

	return $obj;
}

# Copy a package to inc/, with its @ISA tree. $pathname is optional.
sub copy_package {
	my ($self, $pkg, $pathname) = @_;