SVN::Web::Test - automated web testing for SVN::Web

package SVN::Web::Test;

use strict;
use warnings;

our $VERSION = 0.53;

use File::Path;
use File::Spec;
use File::Temp qw(tempdir);
use POSIX ();
use IO::Socket::INET;

use Test::More;
use Test::WWW::Mechanize;

use SVN::Web;
use YAML ();

# CGI.pm does not reinitialise itself from the environment when multiple
# objects are created.  This is a problem when testing, as the tests pass
# in different QUERY_STRING variables.  C<< use CGI >> and increment
# $CGI::PERLEX, which is an internal CGI.pm flag that turns off this
# behaviour.
use CGI;
$CGI::PERLEX++;

my $uri_base;
my $script;
my $fake_cgi = 0;

sub new {
    my $class = shift;
    my $self = bless {}, $class;

    %$self = @_;

    my @mech_args = exists $self->{mech_args} ? $self->{mech_args} : ();

    $self->{_mech} =
      exists $self->{httpd_port} ? Test::WWW::Mechanize->new(@mech_args)
	                         : SVN::Web::Test::Mechanize->new(@mech_args);

    if(! exists $self->{root_url}) {
	if(exists $self->{httpd_port}) {
	    $self->{root_url} = "http://localhost:$self->{httpd_port}/svnweb";
	} else {
	    $self->{root_url} = "http://localhost/svnweb";
	}
    }

    $self->{repo_path} = File::Spec->rel2abs($self->{repo_path});
    $self->{repo_dump} = File::Spec->rel2abs($self->{repo_dump});

    $self->create_env();
    $self->create_install();

    return $self;
}

# Returns the Test::WWW::Mechanize object
sub mech {
    return shift->{_mech};
}

sub install_dir {
    return shift->{install_dir};
}

sub site_root {
    return shift->{root_url};
}

sub set_config {
    my $self = shift;
    my $opts = shift;

    $uri_base = $opts->{uri_base};
    $script   = $opts->{script};
    $fake_cgi = 1;

    my $config = {
	version => $VERSION,
        actions => {
	    'browse' => {
		'class' => 'SVN::Web::Browse',
		'action_menu' => {
		    'show' => [ 'directory' ],
		    'link_text' => '(browse directory)'
		}
	    },
	    'blame' => {
		'class' => 'SVN::Web::Blame',
		'action_menu' => {
		    'show' => [ 'file' ],
		    'link_text' => '(view blame)'
		}
	    },
	    'checkout' => {
		'class' => 'SVN::Web::Checkout',
		'action_menu' => {
		    'show' => [ 'file' ],
		    'link_text' => '(checkout)'
		}
	    },
	    'revision' => {
		'class' => 'SVN::Web::Revision'
	    },
	    'view' => {
		'class' => 'SVN::Web::View',
		'action_menu' => {
		    'show' => [ 'file' ],
		    'link_text' => '(view file)'
		}
	    },
	    'diff' => {
		'class' => 'SVN::Web::Diff'
	    },
	    'log' => {
		'class' => 'SVN::Web::Log',
		'action_menu' => {
		    'show' => [ 'file', 'directory' ],
		    'link_text' => '(view revision log)'
		}
	    },
	    'rss' => {
		'class' => 'SVN::Web::RSS',
		'action_menu' => {
		    'icon' => '/css/trac/feed-icon-16x16.png',
		    'show' => [ 'file', 'directory' ],
		    'head_only' => '1',
		    'link_text' => '(rss)'
		}
	    },
	    'list' => {
		'class' => 'SVN::Web::List'
	    }
        },
        cgi_class    => 'CGI',
        templatedirs => ['lib/SVN/Web/Template/trac'],
	%{$opts->{config}},
    };

    SVN::Web::set_config($config);
}

# Create a Subversion repo from a dump file.
sub create_env {
    my $self = shift;

    plan skip_all => 'Test::WWW::Mechanize not installed'
      unless eval { require Test::WWW::Mechanize; 1; };

    plan skip_all => q{Can't find svnadmin}
      unless `svnadmin --version` =~ /version/;

    rmtree([$self->{repo_path}]) if -d $self->{repo_path};
    $ENV{SVNFSTYPE} ||= (($SVN::Core::VERSION =~ /^1\.0/) ? 'bdb' : 'fsfs');

    `svnadmin create --fs-type=$ENV{SVNFSTYPE} $self->{repo_path}`;
    `svnadmin load $self->{repo_path} < $self->{repo_dump}`;
}

# Create a scratch area, run svnweb-install.  The generated config.yaml
# file will be changed to list the repo created create_env().
#
# Returns the directory in which the scratch area is rooted.
sub create_install {
    my $self = shift;

    $self->{install_dir} = tempdir(CLEANUP => 1);
    warn "Created $self->{install_dir}\n";
    my $cwd = POSIX::getcwd();
    chdir($self->{install_dir});
    my $lib_dir = File::Spec->catdir($cwd, 'blib', 'lib');
    my $svnweb_install = File::Spec->catfile($cwd, 'bin', 'svnweb-install');

    system "$^X -I$lib_dir $svnweb_install";

    # Make the directory world-readable by all.  Otherwise, if Apache is
    # started as root the default behaviour is to set user/group to -1.
    # This results in the directory being unreadable by SVN::Web.
    chmod 0755, $self->{install_dir};

    chdir($cwd);		# Get back to the original directory

    # Change the config to point to the test repo
    my $config_file = File::Spec->catfile($self->{install_dir}, 'config.yaml');
    my $config = YAML::LoadFile($config_file);
    $config->{repos}{repos} = $self->{repo_path};
    YAML::DumpFile($config_file, $config);

    return $self->{install_dir};
}

# Forks and execs the process that will act as the web server.
# Arguments are passed, unchanged, to exec().  Returns the PID of
# the child process
sub start_server {
    my $self = shift;
    my @cmd  = @_;

    # Make sure there's nothing else listening on our chosen port
    my $sock = IO::Socket::INET->new(PeerAddr => 'localhost',
				     PeerPort => $self->{httpd_port},
				     Proto    => 'tcp');
    if(defined $sock) {
	close($sock);
	die "Something else is already listening on port $self->{httpd_port}\n"
    }

    $self->{_pid} = fork();
    die "fork() failed: $!\n" unless defined $self->{_pid};

    if($self->{_pid} == 0) {
	# Set a new process group, so that this, and any children, can be
	# killed by our parent
	POSIX::setpgid(0, $$) or die "setpgid(): $!\n";

	exec @cmd;
	exit;
    }

    # Note the original signal handlers and install our own
    $self->{_sigintr} = $SIG{INT};
    $self->{_sigquit} = $SIG{QUIT};
    $self->{_siggerm} = $SIG{TERM};

    $SIG{INT}  = sub { $self->_sig(@_) };
    $SIG{QUIT} = sub { $self->_sig(@_) };
    $SIG{TERM} = sub { $self->_sig(@_) };

    # The child may take a few seconds to start up.  So wait a second
    # for it to do so, and try and reach the root of the site.  If
    # that doesn't work, lather-rinse-repeat another five times before
    # giving up.
    foreach my $count (1..5) {
	sleep 1;
	last if $self->{_mech}->get($self->{root_url})->code() == 200;
	
	if($count == 5) {
	    kill 15, -$self->{_pid};
	    die "Could not get 200 response from server on port $self->{httpd_port}\n"
	      if $count == 5;
	}
    }

    return $self->{_pid};
}

sub _sig {
    my $self = shift;
    my $sig  = shift;

    if(exists $self->{_pid}) {
	diag "Caught signal $sig, stopping server (pid: $self->{_pid})";
	$self->stop_server();
    }

    # Call the original signal handler
    return $self->{_sigintr} if $sig eq 'INT'  and exists $self->{_sigintr};
    return $self->{_sigquit} if $sig eq 'QUIT' and exists $self->{_sigquit};
    return $self->{_sigterm} if $sig eq 'TERM' and exists $self->{_sigterm};

    return;
}

sub stop_server {
    my $self = shift;
    kill 9, -$self->{_pid};
    wait;
    delete $self->{_pid};
}

# Walk the site
sub walk_site {
    my $self = shift;
    my $test = shift;
    my $seen = shift || {};

    $test->($self);

    my @links = $self->mech()->links();
    for my $i (0 .. $#links) {
        my $link_url = $links[$i]->url_abs;

	diag sprintf "Fetching %d/%d %s (%s)",
	    $i + 1, $#links + 1, $link_url, $links[$i]->text()
		if exists $ENV{TEST_VERBOSE} and $ENV{TEST_VERBOSE};

        next if $seen->{$link_url};
	diag "Skipping $link_url", next
	    if $link_url !~ /(?:localhost|127\.0\.0\.1)/;

        ++$seen->{$link_url};

        $self->mech()->get($link_url);
        $self->walk_site($test, $seen);
        $self->mech()->back;
    }
}

package SVN::Web::Test::Mechanize;

use base qw(Test::WWW::Mechanize);

sub send_request {
    my($self, $request) = @_;

    my $buf = '';
    my $uri = $request->uri;

    my($proto, $hostname) = $uri_base =~ m{(https?)://([^/]+)};
    my $port = $proto eq 'http' ? 80 : 443;

    {
        open my $outfh, '>', \$buf;
        local *STDOUT = $outfh;
        $uri =~ s/^$uri_base$script//;
        $uri =~ s/\?(.*?)(?:#.*)?$//g;
        local $ENV{QUERY_STRING}   = $1 || '';
        local $ENV{PATH_INFO}      = $uri;
        local $ENV{SCRIPT_NAME}    = "$uri_base$script";
        local $ENV{HTTP_HOST}      = "$hostname:$port";
        local $ENV{REQUEST_METHOD} = 'GET';
        SVN::Web::run_cgi();
    }

    my $response = HTTP::Response->new(200);
    my $msg = HTTP::Message->parse($buf);
    $response->header(%{ $msg->headers() });
    $response->content($msg->content());
    $response->request($request);
    $response->header("Client-Date" => HTTP::Date::time2str(time));

    return $response;
}

1;