view release on metacpan or  search on metacpan

lib/Apache/SWIT/Test/ModuleTester.pm  view on Meta::CPAN

	$self->root_class($old_rc);
}

sub install_subsystem {
	my ($self, $name) = @_;
	my $md = $self->module_dir;
	my ($first) = ($md =~ /^([^\/]+)/);
	die "# Unable to find first in $md" unless $first;
	my $inst_dir = $self->install_dir . "/$first";
	symlink($inst_dir, $first);
	symlink("$inst_dir.pm", "$first.pm") if ($first eq $md);
	require "$md/Maker.pm" or die "Unable to require $md/Maker.pm";
	my $mc = $self->root_class . "::Maker";
	$mc->new->install_subsystem($name);
	$self->subsystem_name($name);
}

sub replace_in_file {
	my ($self, $f, $from, $to) = @_;
	my $str = read_file($f);
	$str =~ s/$from/$to/g
		or confess "# Unable to replace $from to $to in $f:\n$str";
	write_file($f, $str);
}

sub insert_into_schema_pm {
	my ($self, $str) = @_;
	$self->replace_in_file('lib/' . $self->module_dir . "/DB/Schema.pm", 
			'shift;', "shift;\n$str");
}

sub install_subsystem_schema {
	my $self = shift;
	my $old_rc = $self->root_class;
	my $sc_class = "$old_rc\::DB::Schema";
	$self->root_class($self->project_class);
	$self->insert_into_schema_pm("use $sc_class;\n"
			. "$sc_class->new(\$dbh)->run_updates;\n");
	$self->root_class($old_rc);
}

sub install_session_base {
	my $self = shift;
	my $old_rc = $self->root_class;
	$self->root_class($self->project_class);
	my $sub_class = $self->root_class . "::" . $self->subsystem_name;
	my $sess_class = "$old_rc\::Session";
	$self->replace_in_file('lib/' . $self->module_dir . "/Session.pm", 
			'use base [^;]+', 
			"use base '$sess_class'");
	$self->root_class($old_rc);

	my $tree = YAML::LoadFile('conf/swit.yaml');
	push @{ $tree->{startup_classes} }, $sess_class;
	YAML::DumpFile('conf/swit.yaml', $tree);
}

sub Drop_Root {
	return if $<;
	unshare_ns() and die;
	system("mount --bind blib/lib /mnt") and die;
	$ENV{PERL5LIB} = "/mnt";
	push @INC, "/mnt";
	Test::TempDatabase->become_postgres_user;
}

1;