[Rt-commit] r5444 - in Test-Chimps: . trunk/bin
trunk/lib/Test/Chimps/Client trunk/t
zev at bestpractical.com
zev at bestpractical.com
Fri Jun 23 17:35:31 EDT 2006
Author: zev
Date: Fri Jun 23 17:35:28 2006
New Revision: 5444
Added:
Test-Chimps/trunk/lib/Test/Chimps/Client/
Test-Chimps/trunk/lib/Test/Chimps/Client/Poller.pm
Test-Chimps/trunk/t/10-server-basic.t
Test-Chimps/trunk/t/15-poller-basic.t
Removed:
Test-Chimps/trunk/t/10-server-base.t
Modified:
Test-Chimps/ (props changed)
Test-Chimps/trunk/bin/poll_and_submit.pl
Test-Chimps/trunk/lib/Test/Chimps/Server.pm
Test-Chimps/trunk/t/05-client-basic.t
Log:
r9688 at galvatron (orig r25): zev | 2006-06-23 17:32:01 -0400
r4258 at galvatron: zev | 2006-06-23 14:10:57 -0400
moved poller to a module
Modified: Test-Chimps/trunk/bin/poll_and_submit.pl
==============================================================================
--- Test-Chimps/trunk/bin/poll_and_submit.pl (original)
+++ Test-Chimps/trunk/bin/poll_and_submit.pl Fri Jun 23 17:35:28 2006
@@ -3,162 +3,14 @@
use warnings;
use strict;
-use Config;
-use Test::Chimps::Report;
-use Test::Chimps::Client;
-use Test::TAP::Model::Visual;
-use YAML::Syck;
-use File::Basename;
-use File::Temp qw/tempdir/;
-use File::Path;
+use lib '/home/zev/bps/Test-Chimps/trunk/lib';
-our $config = LoadFile("/home/zev/bps/poll-config.yml");
-
-our @added_to_inc;
-our @added_to_env;
-our @checkout_paths;
-
-END {
- foreach my $tmpdir (@checkout_paths) {
- remove_tmpdir($tmpdir);
- }
-}
-
-while (1) {
- foreach my $project (keys %{$config}) {
- next if $config->{$project}->{dependency_only};
-
- my $info_out = `svn info $config->{$project}->{svn_uri}`;
- $info_out =~ m/Revision: (\d+)/;
- my $latest_revision = $1;
- $info_out =~ m/Last Changed Revision: (\d+)/;
- my $last_changed_revision = $1;
- $info_out =~ m/Last Changed Author: (\w+)/;
- my $author = $1;
-
- my $old_revision = $config->{$project}->{revision};
-
- next unless $last_changed_revision > $old_revision;
-
- foreach my $revision (($old_revision + 1) .. $latest_revision) {
- # only actually do the check out if the revision and last changed revision match for
- # a particular revision
- next unless revisions_match($config->{$project}->{svn_uri}, $revision);
-
- $config->{$project}->{revision} = $revision;
-
- checkout_project($config->{$project}, $revision);
-
- print "running tests for $project\n";
- my $start_time = time;
- my $model = Test::TAP::Model::Visual->new_with_tests(glob("t/*.t t/*/t/*.t"));
- my $duration = time - $start_time;
-
- foreach my $var (@added_to_env) {
- print "unsetting environment variable $var\n";
- delete $ENV{$var};
- }
- @added_to_env = ();
-
- foreach my $libdir (@added_to_inc) {
- print "removing $libdir from \@INC\n";
- shift @INC;
- }
- @added_to_inc = ();
-
- chdir(File::Spec->rootdir);
-
- foreach my $tmpdir (@checkout_paths) {
- remove_tmpdir($tmpdir);
- }
- @checkout_paths = ();
-
- my $report = Test::Chimps::Report->new(model => $model,
- report_variables =>
- { category => $project,
- subcategory => 'repository snapshot / ' . $Config{osname},
- project => scalar fileparse($config->{$project}->{svn_uri}),
- revision => $revision,
- author => $author,
- timestamp => scalar gmtime,
- duration => $duration});
-
- my $client = Test::Chimps::Client->new(reports => [$report],
- server => 'http://galvatron.mit.edu/cgi-bin/report_server.pl');
-
- my ($status, $msg) = $client->send;
-
- if ($status) {
- print "Sumbitted smoke report for $project revision $revision\n";
- DumpFile("/home/zev/bps/poll-config.yml", $config);
- } else {
- print "Error: the server responded: $msg\n";
- }
- }
- }
- sleep 60;
-}
-
-sub checkout_project {
- my $project = shift;
- my $revision = shift;
-
- my $tmpdir = tempdir("smoke-svn-XXXXXXX", TMPDIR => 1);
- unshift @checkout_paths, $tmpdir;
-
- system("svn", "co", "-r", $revision, $project->{svn_uri}, $tmpdir);
-
- if (defined $project->{env}) {
- foreach my $var (keys %{$project->{env}}) {
- unshift @added_to_env, $var;
- print "setting environment variable $var to $project->{env}->{$var}\n";
- $ENV{$var} = $project->{env}->{$var};
- }
- }
-
- my $projectdir = File::Spec->catdir($tmpdir, $project->{root_dir});
-
- if (defined $project->{dependencies}) {
- foreach my $dep (@{$project->{dependencies}}) {
- print "processing dependency $dep\n";
- checkout_project($config->{$dep});
- }
- }
+use Test::Chimps::Client::Poller;
- chdir($projectdir);
-
- if (defined $project->{configure_cmd}) {
- system($project->{configure_cmd});
- }
-
- for my $libloc (qw{blib/lib}) {
- my $libdir = File::Spec->catdir($tmpdir,
- $project->{root_dir},
- $libloc);
- print "adding $libdir to \@INC\n";
- unshift @added_to_inc, $libdir;
- unshift @INC, $libdir;
- }
-
-
- return $projectdir;
-}
-
-sub remove_tmpdir {
- my $tmpdir = shift;
- print "removing temporary directory $tmpdir\n";
- rmtree($tmpdir, 0, 0);
-}
-
-sub revisions_match {
- my $uri = shift;
- my $revision = shift;
-
- my $info_out = `svn info -r $revision $uri`;
- $info_out =~ m/Revision: (\d+)/;
- my $latest_revision = $1;
- $info_out =~ m/Last Changed Revision: (\d+)/;
- my $last_changed_revision = $1;
+my $poller = Test::Chimps::Client::Poller->new(
+ server => 'http://smoke.bestpractical.com/cgi-bin/report_server.pl',
+ config_file => '/home/zev/bps/poll-config.yml',
+ simulate => 1
+);
- return $latest_revision == $last_changed_revision;
-}
+$poller->poll;
Added: Test-Chimps/trunk/lib/Test/Chimps/Client/Poller.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/trunk/lib/Test/Chimps/Client/Poller.pm Fri Jun 23 17:35:28 2006
@@ -0,0 +1,274 @@
+package Test::Chimps::Client::Poller;
+
+use warnings;
+use strict;
+
+use Config;
+use File::Basename;
+use File::Path;
+use File::Temp qw/tempdir/;
+use Params::Validate qw/:all/;
+use Test::Chimps::Client;
+use Test::Chimps::Report;
+use Test::TAP::Model::Visual;
+use YAML::Syck;
+
+=head1 NAME
+
+Test::Chimps::Client - Poll a set of SVN repositories and run tests when they change
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+=head1 SYNOPSIS
+
+This module gives you everything you need to make your own build
+slave. You give it a configuration file describing all of your
+projects and how to test them, and it will monitor the SVN
+repositories, check the projects out (and their dependencies), test
+them, and submit the report to a server.
+
+ use Test::Chimps::Client::Poll;
+
+ my $poller = Test::Chimps::Client::Poll->new(
+ server => 'http://www.example.com/cgi-bin/smoke-server.pl',
+ config_file => '/path/to/configfile.yml'
+ )
+
+ $poller->poll();
+
+=head1 METHODS
+
+=head2 new ARGS
+
+Creates a new Client object. ARGS is a hash whose valid keys are:
+
+=over 4
+
+=item * config_file
+
+Mandatory. The configuration file describing which repositories to
+monitor. The format of the configuration is described in
+L</CONFIGURATION FILE>.
+
+=item * server
+
+Mandatory. The URI of the server script to upload the reports to.
+
+=item * simulate
+
+Don't actually submit the smoke reports, just run the tests. This
+I<does>, however, increment the revision numbers in the config
+file.
+
+=back
+
+=cut
+
+use base qw/Class::Accessor/;
+Test::Chimps::Client::Poller->mk_ro_accessors(qw/server config_file simulate/);
+Test::Chimps::Client::Poller->mk_accessors(
+ qw/_added_to_inc _added_to_env _checkout_paths _config/);
+
+# add a signal handler so destructor gets run
+$SIG{INT} = sub {print "caught sigint. cleaning up...\n"; exit(1)};
+
+sub new {
+ my $class = shift;
+ my $obj = bless {}, $class;
+ $obj->_init(@_);
+ return $obj;
+}
+
+sub _init {
+ my $self = shift;
+ my %args = validate_with(params => \@_,
+ spec =>
+ { server => 1,
+ config_file => 1,
+ simulate => 0},
+ called => 'The Test::Chimps::Client::Poll constructor');
+
+ foreach my $key (keys %args) {
+ $self->{$key} = $args{$key};
+ }
+ $self->_added_to_inc([]);
+ $self->_added_to_env([]);
+ $self->_checkout_paths([]);
+
+ $self->_config(LoadFile($self->config_file));
+}
+
+sub DESTROY {
+ my $self = shift;
+ foreach my $tmpdir (@{$self->_checkout_paths}) {
+ _remove_tmpdir($tmpdir);
+ }
+}
+
+=head2 poll
+
+Calling poll will cause the C<Poll> object to continually poll
+repositories for changes in revision numbers. If an (actual)
+change is detected, the repository will be checked out (with
+dependencies), built, and tested, and the resulting report will be
+submitted to the server. This method does not return.
+
+=cut
+
+sub poll {
+ my $self = shift;
+ my $config = $self->_config;
+ while (1) {
+ foreach my $project (keys %{$config}) {
+ next if $config->{$project}->{dependency_only};
+
+ my $info_out = `svn info $config->{$project}->{svn_uri}`;
+ $info_out =~ m/Revision: (\d+)/;
+ my $latest_revision = $1;
+ $info_out =~ m/Last Changed Revision: (\d+)/;
+ my $last_changed_revision = $1;
+ $info_out =~ m/Last Changed Author: (\w+)/;
+ my $author = $1;
+
+ my $old_revision = $config->{$project}->{revision};
+
+ next unless $last_changed_revision > $old_revision;
+
+ foreach my $revision (($old_revision + 1) .. $latest_revision) {
+ # only actually do the check out if the revision and last changed revision match for
+ # a particular revision
+ next unless _revisions_match($config->{$project}->{svn_uri}, $revision);
+
+ $config->{$project}->{revision} = $revision;
+
+ $self->_checkout_project($config->{$project}, $revision);
+
+ print "running tests for $project\n";
+ my $start_time = time;
+ my $model = Test::TAP::Model::Visual->new_with_tests(glob("t/*.t t/*/t/*.t"));
+ my $duration = time - $start_time;
+
+ foreach my $var (@{$self->_added_to_env}) {
+ print "unsetting environment variable $var\n";
+ delete $ENV{$var};
+ }
+ $self->_added_to_env([]);
+
+ foreach my $libdir (@{$self->_added_to_inc}) {
+ print "removing $libdir from \@INC\n";
+ shift @INC;
+ }
+ $self->_added_to_inc([]);
+
+ chdir(File::Spec->rootdir);
+
+ foreach my $tmpdir (@{$self->_checkout_paths}) {
+ _remove_tmpdir($tmpdir);
+ }
+ $self->_checkout_paths([]);
+
+ my $report = Test::Chimps::Report->new(model => $model,
+ report_variables =>
+ { category => $project,
+ subcategory => 'repository snapshot / ' . $Config{osname},
+ project => scalar fileparse($config->{$project}->{svn_uri}),
+ revision => $revision,
+ author => $author,
+ timestamp => scalar gmtime,
+ duration => $duration});
+
+ my $client = Test::Chimps::Client->new(reports => [$report],
+ server => 'http://galvatron.mit.edu/cgi-bin/report_server.pl');
+
+ my ($status, $msg);
+ if ($self->simulate) {
+ $status = 1;
+ } else {
+ ($status, $msg) = $client->send;
+ }
+
+ if ($status) {
+ print "Sumbitted smoke report for $project revision $revision\n";
+ DumpFile("/home/zev/bps/poll-config.yml", $config);
+ } else {
+ print "Error: the server responded: $msg\n";
+ }
+ }
+ }
+ sleep 60;
+ }
+}
+
+sub _checkout_project {
+ my $self = shift;
+ my $project = shift;
+ my $revision = shift;
+
+ my $tmpdir = tempdir("chimps-svn-XXXXXXX", TMPDIR => 1);
+ unshift @{$self->_checkout_paths}, $tmpdir;
+
+ system("svn", "co", "-r", $revision, $project->{svn_uri}, $tmpdir);
+
+ if (defined $project->{env}) {
+ foreach my $var (keys %{$project->{env}}) {
+ unshift @{$self->_added_to_env}, $var;
+ print "setting environment variable $var to $project->{env}->{$var}\n";
+ $ENV{$var} = $project->{env}->{$var};
+ }
+ }
+
+ my $projectdir = File::Spec->catdir($tmpdir, $project->{root_dir});
+
+ if (defined $project->{dependencies}) {
+ foreach my $dep (@{$project->{dependencies}}) {
+ print "processing dependency $dep\n";
+ $self->_checkout_project($self->_config->{$dep}, 'HEAD');
+ }
+ }
+
+ chdir($projectdir);
+
+ if (defined $project->{configure_cmd}) {
+ system($project->{configure_cmd});
+ }
+
+ for my $libloc (qw{blib/lib}) {
+ my $libdir = File::Spec->catdir($tmpdir,
+ $project->{root_dir},
+ $libloc);
+ print "adding $libdir to \@INC\n";
+ unshift @{$self->_added_to_inc}, $libdir;
+ unshift @INC, $libdir;
+ }
+
+
+ return $projectdir;
+}
+
+sub _remove_tmpdir {
+ my $tmpdir = shift;
+ print "removing temporary directory $tmpdir\n";
+ rmtree($tmpdir, 0, 0);
+}
+
+sub _revisions_match {
+ my $uri = shift;
+ my $revision = shift;
+
+ my $info_out = `svn info -r $revision $uri`;
+ $info_out =~ m/Revision: (\d+)/;
+ my $latest_revision = $1;
+ $info_out =~ m/Last Changed Revision: (\d+)/;
+ my $last_changed_revision = $1;
+
+ return $latest_revision == $last_changed_revision;
+}
+
+
+1;
Modified: Test-Chimps/trunk/lib/Test/Chimps/Server.pm
==============================================================================
--- Test-Chimps/trunk/lib/Test/Chimps/Server.pm (original)
+++ Test-Chimps/trunk/lib/Test/Chimps/Server.pm Fri Jun 23 17:35:28 2006
@@ -176,7 +176,7 @@
optional => 1 }
});
- foreach my $key (%args) {
+ foreach my $key (keys %args) {
$self->{$key} = $args{$key};
}
}
Modified: Test-Chimps/trunk/t/05-client-basic.t
==============================================================================
--- Test-Chimps/trunk/t/05-client-basic.t (original)
+++ Test-Chimps/trunk/t/05-client-basic.t Fri Jun 23 17:35:28 2006
@@ -16,8 +16,9 @@
my $reports = [$r];
my $c = Test::Chimps::Client->new(reports => $reports,
- server => 'bogus',
- compress => 1);
+ server => 'bogus',
+ compress => 1);
+
ok($c, "the client object is defined");
isa_ok($c, 'Test::Chimps::Client', "and it's of the correct type");
Added: Test-Chimps/trunk/t/10-server-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/trunk/t/10-server-basic.t Fri Jun 23 17:35:28 2006
@@ -0,0 +1,12 @@
+#!perl -T
+
+use Test::More tests => 3;
+
+BEGIN {
+ use_ok('Test::Chimps::Server');
+}
+
+my $s = Test::Chimps::Server->new(base_dir => '/var/www');
+
+ok($s, "the server object is defined");
+isa_ok($s, 'Test::Chimps::Server', "and it's of the correct type");
Added: Test-Chimps/trunk/t/15-poller-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/trunk/t/15-poller-basic.t Fri Jun 23 17:35:28 2006
@@ -0,0 +1,13 @@
+#!perl -T
+
+use Test::More tests => 3;
+
+BEGIN {
+ use_ok('Test::Chimps::Client::Poller');
+}
+
+my $s = Test::Chimps::Client::Poller->new(server => 'bogus',
+ config_file => '/home/zev/bps/poll-config.yml');
+
+ok($s, "the server object is defined");
+isa_ok($s, 'Test::Chimps::Client::Poller', "and it's of the correct type");
More information about the Rt-commit
mailing list