view release on metacpan or  search on metacpan

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

sub write_seal_key {
	swmani_write_file("conf/seal.key"
		, md5_hex(Crypt::CBC->random_bytes(8)));
}

sub write_httpd_conf_in {
	my $self = shift;
	my $rl = Apache::SWIT::Maker::Config->instance->root_location;
	my $an = Apache::SWIT::Maker::Config->instance->app_name;
	swmani_write_file('conf/httpd.conf.in', <<ENDM);
RewriteEngine on
RewriteRule ^/\$ $rl/index/r [R]
Alias $rl/www \@ServerRoot\@/public_html 
Alias /html-tested-javascript /usr/local/share/libhtml-tested-javascript-perl
# Format is:
# Remote IP, time, request, status, duration, referer, user agent
# PID, Cookie, total bytes in request, total bytes in response
LogFormat "%a %t \\"%r\\" %>s %D \\"%{Referer}i\\" \\"%{User-Agent}i\\" %P %{$an}C %I %O" switlog
ENDM
}

sub add_test {
	my ($self, $file, $number, $content) = @_;
	unless ($number) {
		$number = 1;
		$content = "BEGIN { use_ok('"
			. Apache::SWIT::Maker::Config->instance->root_class
			."'); }";
	}
	swmani_write_file($file, <<ENDT);
use strict;
use warnings FATAL => 'all';

use Test::More tests => $number;

$content
ENDT
}

sub write_010_db_t {
	shift()->add_test('t/010_db.t', 1, <<ENDM);
use T::TempDB;

package T::DBI;
use base 'Apache::SWIT::DB::Base';
__PACKAGE__->table('test_table');
__PACKAGE__->columns(Essential => qw/a b/);

package main;
Apache::SWIT::DB::Connection->instance->db_handle->do(
		"create table test_table (a integer, b text)");
is_deeply([ T::DBI->retrieve_all ], []);

ENDM
}

sub write_swit_app_pl {
	my $self = shift;
	$self->file_writer->write_scripts_swit_app_pl({
				class => ref($self) });
	chmod 0755, 'scripts/swit_app.pl';
}

sub install {
	my ($self, $inst_dir) = @_;
	my $si = Apache::SWIT::Maker::Config->instance->{skip_install} || [];
	my %skips = map {
		my $v = read_file($_) or die "Nothing for $_";
		($_, $v);
	} map { "blib/$_" } @$si;
	unlink($_) for keys %skips;
	$self->makefile_class->do_install("blib", $inst_dir);
	write_file($_, $skips{$_}) for keys %skips;
}

sub write_initial_files {
	my $self = shift;
	$self->$_->new->write_output for @_initial_skels;

	$self->write_swit_yaml;
	$self->write_session_pm;
	$self->write_db_schema_file;
	$self->write_test_db_file;
	$self->write_t_extra_conf_in;
	$self->write_httpd_conf_in;
	$self->write_seal_key;
	swmani_write_file("public_html/main.css", "# Sample CSS file\n");
	$self->file_writer->write_t_direct_test_pl;

	my $rc = Apache::SWIT::Maker::Config->instance->root_class;
	$self->file_writer->write_conf_makefile_rules_yaml({ rc => $rc });

	$self->write_makefile_pl;
	$self->write_010_db_t;
	$self->write_swit_app_pl;
	$self->add_ht_page('Index');
}

sub dump_db {
	push @INC, "t", "lib";
	unlink("t/conf/schema.sql");
	system("touch t/conf/schema.sql && chmod a+rw t/conf/schema.sql")
		unless ($<);
	conv_eval_use('T::TempDB');
	system("pg_dump -c $ENV{APACHE_SWIT_DB_NAME} > t/conf/schema.sql");
}

sub _make_page {
	my ($self, $page_class, $args, @funcs) = @_;
	my $i = Apache::SWIT::Maker::Config->instance;
	my $e = $i->create_new_page($page_class);
	for my $f (@funcs) {
		my $p = $self->$f->new($args);
		$p->config_entry($e);
		$p->write_output;
	}
	$i->save;
	return $e;
}

=head2 add_page(page)

Adds page and related files. Page should be the name of the module, 
e.g. 'Index'. See C<add_ht_page> for adding HTML::Tested enabled page.

=cut
sub add_page {
	my ($self, $pc) = @_;
	return $self->_make_page($pc, {}, qw(skel_template skel_page));
}

=head2 add_ht_page(page)

Adds HTML::Tested enabled page and related files. 
Page should be the name of the module, e.g. 'Index'.

=cut
sub add_ht_page {
	my ($self, $pc) = @_;
	return $self->_make_page($pc, {}, qw(skel_ht_template skel_ht_page));
}

sub _location_section_start {
	my ($self, $l, $c, $h) = @_;
return <<ENDS
<Location $l>
	SetHandler perl-script
	PerlHandler $c\->$h
ENDS
}

sub gen_conf_header {
	return <<ENDS;
<IfModule !apreq_module.c>
	LoadModule apreq_module /usr/lib/apache2/modules/mod_apreq2.so
</IfModule>
<IfModule !rewrite_module.c>
	LoadModule rewrite_module /usr/lib/apache2/modules/mod_rewrite.so
</IfModule>
<IfModule !mod_deflate.c>
	LoadModule deflate_module /usr/lib/apache2/modules/mod_deflate.so
</IfModule>

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

, 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;