view release on metacpan or  search on metacpan

lib/Apache/SWIT/Maker.pm  view on Meta::CPAN

	}
	write_file('conf/swit.yaml', $cstr);

	# change test functions
	my ($tf_f, $tf_t) = ($ef, $et);
	s#\/#_#g for ($tf_f, $tf_t);
	swmani_replace_in_files(-f $to ? sub {
		s/ht_$tf_f(_\w)\b/ht_$tf_t$1/g;
	} : ("ht_$tf_f", "ht_$tf_t"));

	my $tt_ef = "templates/$ef";
	if (-f $to) {
		$tt_ef .= ".tt";
		$et .= ".tt";
	}
	$self->mv($tt_ef, "templates/$et") if ($cstr =~ m#$tt_ef#);
}

sub available_commands { return (
add_class => [ '<class> - adds new class.', 1 ]
, add_db_class => [ '<class> - adds new database class.', 1 ]
, add_ht_page => [ '<class> - adds new HTML::Tested based page.', 1 ]
, add_page => [ '<class> - adds new page.', 1 ]
, add_test => [ '<file> - adds new test file.' ]
, install => [ '<dir> - installs into dir.' ]
, mv => [ '<from> <to> - moves file or directory updating all things which
		reference it.', 1 ]
, override => [ '<class> - overrides page class by inheriting from it.' ]
, regenerate_httpd_conf => [ '- regenerates httpd.conf.' ]
, run_server => [ '<host:port> <db> - runs Apache on optional host:port using
			db name if given.' ]
, scaffold => [ '<table_name> - generates classes and templates supporting
		<table_name> CRUD operation.', 1 ]
, add_migration => [ '<name> <sql> - create migration test target', 1 ]
, freeze_schema => [ 'freezes schema' ]
, dump_db => [ 'dumps temporary database into t/conf/schema.sql' ]
, test_root => [ 'Runs tests in temporary directory as different user' ]
); }

sub swit_app_cmd_params {
	my ($self, $cmd) = @_;
	my %cmds = $self->available_commands;
	return $cmds{$cmd} if ($cmd && $cmds{$cmd});
	my $res = "Usage: $0 <cmd> <args> where available commands are:\n";
	for my $n (sort keys %cmds) {
		my $v = $cmds{$n};
		$res .= "$n $v->[0]\n";
	}
	print $res;
	return undef;
}

sub do_swit_app_cmd {
	my ($self, $cmd, @args) = @_;
	my $p = $self->swit_app_cmd_params($cmd) or return;
	my ($mf_before);
	local $ExtUtils::Manifest::Quiet = 1;
	my $bf_name = join("_", $cmd, @args);
	$bf_name =~ s/\W/_/g;
	my $cwd = getcwd();
	my $backup_dir = "$cwd/../$bf_name";
	if ($p->[1]) {
		$mf_before = maniread();
		manicopy($mf_before, $backup_dir);
		conv_silent_system("make realclean") if -f 'Makefile';
	}
	eval { $self->$cmd(@args); };
	my $err = $@;
	if ($err && $p->[1]) {
		chdir $backup_dir;
		manicopy($mf_before, $cwd);
		chdir $cwd;
	} elsif ($p->[1]) {
		mkpath("backups");
		my $mf = maniread();
		$mf->{$_} = 1 for keys %$mf_before;
		# diff returns 1 for some reason
		system("diff -uN $backup_dir/$_ $_ >> backups/$bf_name.patch")
				for (sort keys %$mf);
		conv_silent_system("perl Makefile.PL");
	}
	rmtree($backup_dir) if $p->[1];
	die "Rolled back. Original exception is $err" if $err;
	return 1;
}

sub test_root {
	my ($self, @args) = @_;
	my $td = tempdir("/tmp/swit_test_root_XXXXXX");
	my $cwd = abs_path(getcwd());
	my $mfiles = maniread();
	manicopy($mfiles, $td);
	chdir $td;
	system("chmod a+rwx `find . -type d`") and die;
	system("chmod a+rw `find . -type f`") and die;
	eval "use Test::TempDatabase";

	my $dn = __FILE__;
	for (; basename($dn) ne 'Apache'; $dn = dirname($dn))
		{} # nothing
	system("cp -a $dn .") and die;

	my $pid = fork();
	if (!$pid) {
		Test::TempDatabase->become_postgres_user;
		system("perl Makefile.PL") and die;
		system("make") and die;
		system("ln -s `pwd`/Apache blib/lib/Apache") and die;
		system("make", @args) and die;
		exit;
	}
	waitpid $pid, 0;
	die "Child finished abnormally: $?" if $?;
	my @to_copy = map { chomp; $_; } `find . -newer Makefile -type f`;
	for my $f (grep { !/^\.\/blib/ } @to_copy) {
		mkpath($cwd . "/" . dirname($f));
		copy($f, "$cwd/$f") or die $f;
	}
	chdir($cwd);
	rmtree($td);
}

1;