[Rt-commit] r5509 - in Test-Chimps: . branches/dbi branches/dbi/bin
branches/dbi/examples branches/dbi/lib branches/dbi/lib/Test
branches/dbi/lib/Test/Chimps
branches/dbi/lib/Test/Chimps/Server branches/dbi/t
branches/dbi/t/bogus-tests
zev at bestpractical.com
zev at bestpractical.com
Mon Jul 3 18:18:54 EDT 2006
Author: zev
Date: Mon Jul 3 18:18:52 2006
New Revision: 5509
Added:
Test-Chimps/branches/dbi/ (props changed)
Test-Chimps/branches/dbi/Changes
Test-Chimps/branches/dbi/MANIFEST
Test-Chimps/branches/dbi/Makefile.PL
Test-Chimps/branches/dbi/README
Test-Chimps/branches/dbi/TODO
Test-Chimps/branches/dbi/bin/
Test-Chimps/branches/dbi/bin/poll_and_submit.pl (contents, props changed)
Test-Chimps/branches/dbi/bin/report_server.pl (contents, props changed)
Test-Chimps/branches/dbi/bin/submit_report.pl (contents, props changed)
Test-Chimps/branches/dbi/examples/
Test-Chimps/branches/dbi/examples/list.tmpl
Test-Chimps/branches/dbi/lib/
Test-Chimps/branches/dbi/lib/Test/
Test-Chimps/branches/dbi/lib/Test/Chimps/
Test-Chimps/branches/dbi/lib/Test/Chimps.pm
Test-Chimps/branches/dbi/lib/Test/Chimps/Client/
Test-Chimps/branches/dbi/lib/Test/Chimps/Client.pm
Test-Chimps/branches/dbi/lib/Test/Chimps/Client/Poller.pm
Test-Chimps/branches/dbi/lib/Test/Chimps/Report.pm
Test-Chimps/branches/dbi/lib/Test/Chimps/Server/
Test-Chimps/branches/dbi/lib/Test/Chimps/Server.pm
Test-Chimps/branches/dbi/lib/Test/Chimps/Server/Lister.pm
Test-Chimps/branches/dbi/t/
Test-Chimps/branches/dbi/t/00-dependencies.t
Test-Chimps/branches/dbi/t/01-report-basic.t
Test-Chimps/branches/dbi/t/05-client-basic.t
Test-Chimps/branches/dbi/t/10-server-basic.t
Test-Chimps/branches/dbi/t/15-poller-basic.t
Test-Chimps/branches/dbi/t/20-lister-basic.t
Test-Chimps/branches/dbi/t/bogus-tests/
Test-Chimps/branches/dbi/t/bogus-tests/00-basic.t
Test-Chimps/branches/dbi/t/boilerplate.t
Test-Chimps/branches/dbi/t/pod-coverage.t
Test-Chimps/branches/dbi/t/pod.t
Modified:
Test-Chimps/ (props changed)
Log:
r9774 at galvatron: zev | 2006-07-02 20:31:10 -0400
really created dbi branch
Added: Test-Chimps/branches/dbi/Changes
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/Changes Mon Jul 3 18:18:52 2006
@@ -0,0 +1,5 @@
+Revision history for Test-Chimps
+
+0.01 Fri Jun 16 13:21:11 EDT 2006
+ First revision.
+
Added: Test-Chimps/branches/dbi/MANIFEST
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/MANIFEST Mon Jul 3 18:18:52 2006
@@ -0,0 +1,34 @@
+bin/poll_and_submit.pl
+bin/report_server.pl
+bin/submit_report.pl
+Changes
+examples/list.tmpl
+inc/Module/AutoInstall.pm
+inc/Module/Install.pm
+inc/Module/Install/AutoInstall.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/Test/Chimps.pm
+lib/Test/Chimps/Client.pm
+lib/Test/Chimps/Report.pm
+lib/Test/Chimps/Server.pm
+Makefile.PL
+MANIFEST
+META.yml # Will be created by "make dist"
+README
+t
+t/00-dependencies.t
+t/01-report-basic.t
+t/05-client-basic.t
+t/10-server-base.t
+t/bogus-tests
+t/bogus-tests/00-basic.t
+t/boilerplate.t
+t/pod-coverage.t
+t/pod.t
Added: Test-Chimps/branches/dbi/Makefile.PL
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/Makefile.PL Mon Jul 3 18:18:52 2006
@@ -0,0 +1,22 @@
+use inc::Module::Install;
+
+# Define metadata
+name 'Test-Chimps';
+all_from 'lib/Test/Chimps.pm';
+
+# Specific dependencies
+requires('Algorithm::TokenBucket');
+requires('Class::Accessor');
+requires('Date::Parse');
+requires('DateTime');
+requires('HTML::Mason');
+requires('LWP::UserAgent');
+requires('Module::CoreList');
+requires('Params::Validate');
+requires('Test::Dependencies');
+requires('Test::TAP::HTMLMatrix');
+requires('Test::TAP::Model::Visual');
+requires('YAML::Syck');
+
+auto_install;
+WriteAll;
Added: Test-Chimps/branches/dbi/README
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/README Mon Jul 3 18:18:52 2006
@@ -0,0 +1,44 @@
+Test-Chimps
+
+This module modularizes the pugs smoke server/client
+(smokeserv-client.pl and smokeserv-server.pl). It also makes the
+code more generic so that other groups can take advantage of the
+simple but powerful smoke server. It will provide scripts to
+replicate pugs' scripts behavior in a more generic fashion.
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+
+SUPPORT AND DOCUMENTATION
+
+After installing, you can find documentation for this module with the perldoc command.
+
+ perldoc Test::Chimps
+
+You can also look for information at:
+
+ Search CPAN
+ http://search.cpan.org/dist/Test-Chimps
+
+ CPAN Request Tracker:
+ http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Chimps
+
+ AnnoCPAN, annotated CPAN documentation:
+ http://annocpan.org/dist/Test-Chimps
+
+ CPAN Ratings:
+ http://cpanratings.perl.org/d/Test-Chimps
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2006 Zev Benjamin
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
Added: Test-Chimps/branches/dbi/TODO
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/TODO Mon Jul 3 18:18:52 2006
@@ -0,0 +1,10 @@
+* add options to to Poll
+* move Poll to SVN::Client
+* document variable requirements
+* move Server to a db
+* limit display
+* change category/subcategory handling
+* add command line switches to binaries?
+* add HTML::Scrubber
+* allow single test comparison back through revisions
+* add option defaults to Poller
\ No newline at end of file
Added: Test-Chimps/branches/dbi/bin/poll_and_submit.pl
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/bin/poll_and_submit.pl Mon Jul 3 18:18:52 2006
@@ -0,0 +1,14 @@
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use Test::Chimps::Client::Poller;
+
+my $poller = Test::Chimps::Client::Poller->new(
+ server => 'http://smoke.bestpractical.com/cgi-bin/report_server.pl',
+ config_file => "$ENV{HOME}/poll-config.yml",
+ simulate => 1
+);
+
+$poller->poll;
Added: Test-Chimps/branches/dbi/bin/report_server.pl
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/bin/report_server.pl Mon Jul 3 18:18:52 2006
@@ -0,0 +1,20 @@
+#!/usr/bin/env perl
+
+use lib '/home/zev/bps/Test-Chimps/branches/categories-rework/lib';
+
+use Test::Chimps::Server;
+
+my $server = Test::Chimps::Server->new(base_dir => '/var/www/bps-smokes',
+ list_template => 'list2.tmpl',
+ variables_validation_spec =>
+ { project => 1,
+ revision => 1,
+ author => 1,
+ timestamp => 1,
+ duration => 1,
+ osname => 1,
+ osver => 1,
+ archname => 1
+ });
+
+$server->handle_request;
Added: Test-Chimps/branches/dbi/bin/submit_report.pl
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/bin/submit_report.pl Mon Jul 3 18:18:52 2006
@@ -0,0 +1,34 @@
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use Getopt::Long;
+use Test::Chimps::Report;
+use Test::Chimps::Client;
+use Test::TAP::Model::Visual;
+
+chdir "jifty/trunk";
+
+my $start_time = time;
+my $model = Test::TAP::Model::Visual->new_with_tests(glob("t/*.t t/*/t/*.t"));
+my $duration = time - $start_time;
+
+my $report = Test::Chimps::Report->new(model => $model,
+ report_variables =>
+ { category => 'Jifty',
+ subcategory => 'repository snapshot / Linux',
+ project => 'jifty',
+ revision => 5,
+ 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 "Error: $msg\n";
+ exit(1);
+}
Added: Test-Chimps/branches/dbi/examples/list.tmpl
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/examples/list.tmpl Mon Jul 3 18:18:52 2006
@@ -0,0 +1,123 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
+ "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
+<head>
+ <title>Smoke Reports</title>
+ <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+
+ <style type="text/css">
+ body {
+ background-color: white;
+ margin: 0;
+
+ font-family: sans-serif;
+ line-height: 1.3em;
+ font-size: 95%;
+ }
+
+ h1, h2 {
+ background-color: #313052;
+ color: white;
+ padding: 10px;
+ }
+
+ th { text-align: left; }
+ .category { padding-top: 30px; border-bottom: 2px solid #313052; }
+ .subcategory { padding-top: 10px; border-bottom: 1px solid #313052; }
+ .report_summary { padding-left: 40px; }
+ .report_details { padding-left: 80px; padding-bottom: 10px; }
+
+ p, dl, pre, table { margin: 15px; }
+ dt { font-weight: bold; }
+ dd+dt { margin-top: 1em; }
+ .leftsep { padding-left: 10px; }
+ .num { text-align: right; }
+
+ .details { display: none; }
+ .expander { color: blue; cursor: pointer; } /* hack? */
+
+ .tests_ok { color: #050; }
+ .tests_failed { color: #500; }
+ .tests_todo { color: #030; }
+ .tests_skipped { color: #555; }
+ .tests_unexpect { color: #550; }
+ </style>
+
+ <script type="text/javascript">//<![CDATA[[
+ function toggle_visibility (id) {
+ var elem = document.getElementById("details_" + id),
+ expander = document.getElementById("expander_" + id);
+ if(elem.className == "details") {
+ elem.className = ""; /* hack? */
+ expander.innerHTML = "«";
+ } else {
+ elem.className = "details";
+ expander.innerHTML = "»";
+ }
+ }
+ //]]></script>
+</head>
+
+<body>
+ <h1>Smoke Reports</h1>
+
+ <p>
+ Note that old smoke reports may be automatically deleted, so you may not want
+ to link directly to a smoke.
+ </p>
+
+ <p>
+ Timezone is UTC
+ </p>
+
+ <table>
+% foreach my $category (sort keys %$categories) {
+ <tr><th colspan="11" class="category"><% $category %></th></tr>
+% foreach my $subcategory (sort keys %{$categories->{$category}}) {
+ <tr><th colspan="11" class="subcategory"><% $subcategory %></th></tr>
+% foreach my $report (@{$categories->{$category}->{$subcategory}}) {
+% my $id = $report->{id};
+% my $data = $report->report_variables;
+% my $model = Test::TAP::Model::Visual->new_with_struct($report->model_structure);
+ <tr>
+ <td class="report_summary"><% $data->{project} %></td>
+ <td>
+ r<% $data->{revision} %>
+ </td>
+ <td class="leftsep"><% $data->{author} %></td>
+ <td class="leftsep"><% $data->{timestamp} %></td>
+ <td class="leftsep num"><% $data->{duration} %> sec</td>
+ <td class="leftsep num"><% sprintf("%.2f", $model->total_ratio * 100) %>% ok</td>
+ <td class="leftsep num tests_total"><span title="<% $model->total_seen %> total"><% $model->total_seen %></span>:</td>
+ <td class="num tests_ok"><span title="<% $model->total_ok %> ok"><% $model->total_ok %></span>,</td>
+ <td class="num tests_failed"><span title="<% $model->total_failed %> failed"><% $model->total_failed %></span>,</td>
+ <td class="num tests_todo"><span title="<% $model->total_todo %> todo"><% $model->total_todo %></span>,</td>
+ <td class="num tests_skipped"><span title="<% $model->total_skipped %> skipped"><% $model->total_skipped %></span>,</td>
+ <td class="num tests_unexpect"><span title="<% $model->total_unexpectedly_succeeded %> unexpectedly succeeded"><% $model->total_unexpectedly_succeeded %></span></td>
+ <td><span title="Details" class="expander" onclick="toggle_visibility('<% $id %>')" id="expander_<% $id %>">»</span></td>
+ <td><a style="text-decoration: none" href="<% $report->{url} %>" title="Full smoke report">»</a></td>
+ </tr>
+ <tr class="details" id="details_<% $id %>">
+ <td colspan="11" class="report_details">
+ <span class="tests_total"><% $model->total_seen %> test cases</span>:<br />
+ <span class="tests_ok"><% $model->total_ok %> ok</span>,
+ <span class="tests_failed"><% $model->total_failed %> failed</span>,
+ <span class="tests_todo"><% $model->total_todo %> todo</span>,<br />
+ <span class="tests_skipped"><% $model->total_skipped %> skipped</span> and
+ <span class="tests_unexpect"><% $model->total_unexpectedly_succeeded %> unexpectedly succeeded</span>
+ <br />
+ <a href="<% $report->{url} %>" title="Full smoke report">View full smoke report</a>
+ </td>
+ </tr>
+% }
+% }
+% }
+ </table>
+</body>
+</html>
+
+<%args>
+$categories
+</%args>
+
Added: Test-Chimps/branches/dbi/lib/Test/Chimps.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/lib/Test/Chimps.pm Mon Jul 3 18:18:52 2006
@@ -0,0 +1,116 @@
+=head1 NAME
+
+Test::Chimps - Collaborative Heterogeneous Infinite Monkey Perfectionification Service
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+=head1 SYNOPSIS
+
+Why run tests yourself? Let an infinite number of monkeys do it
+for you! Take the monkey work out of testing. Remove the monkey
+wrench from your development process. Will the monkey jokes ever
+end? No! We really are more fun than a barrel full of monkeys!
+
+The Collaborative Heterogeneous Infinite Monkey Perfectionification
+Service (CHIMPS) is a generalized testing framework designed to
+make integration testing easy. You use L<Test::Chimps::Server> to
+create your CGI script for viewing and submitting reports, and you
+use L<Test::Chimps::Client> for submitting reports. You will find
+some scripts in the examples directory which should get you
+started.
+
+=head1 PHILOSOPHY
+
+Tests are good. Testing is easy thanks to modules like
+L<Test::Simple> and L<Test::More>. However, it's easy to forget to
+run C<make test> every time you commit. Worse, you might have
+forgotten to add a file that will cause tests to fail on a freshly
+checked out copy. Additionally, your tests might only pass on your
+version of perl or with specific module versions.
+
+Chimps aims to solve these problems. However, it tries to make as
+few assumptions about how your integration testing architecture
+should work as possible. Want to allow anyone to submit smoke
+reports? Just write a wrapper around C<Test::Chimps::Client>.
+Want to have dedicated build hosts that continuously check out and
+test projects? Just use C<Test::Chimps::Client::Poller>. Whatever
+your integration testing architecture, you can probably use Chimps
+to simplify the process.
+
+=head1 REPORT VARIABLES
+
+Chimps does not make any assumptions about what kind of data is
+carried in your smoke reports. These data are called I<report
+variables>. When creating a server with C<Test::Chimps::Server>,
+you can specify which variables must be submitted with each
+report. Unfortunately, if we I<never> made any assumptions, it
+would be hard to write any utility code. Therefore, several Chimps
+modules have documentation sections describing variables that it
+assumes are passed to the server. These are probably pretty
+reasonable assumptions for most set ups. However, if they do not
+meet your needs, it should be fairly easy to subclass the
+appropriate classes and add the functionality and variables you
+require.
+
+=head1 AUTHOR
+
+Zev Benjamin, C<< <zev at cpan.org> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-test-chimps at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Chimps>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Chimps
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Test-Chimps>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Test-Chimps>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Chimps>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Test-Chimps>
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+The code in this distribution is based on smokeserv-client.pl and
+smokeserv-server.pl from the Pugs distribution.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2006 Zev Benjamin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
+
Added: Test-Chimps/branches/dbi/lib/Test/Chimps/Client.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/lib/Test/Chimps/Client.pm Mon Jul 3 18:18:52 2006
@@ -0,0 +1,201 @@
+package Test::Chimps::Client;
+
+use warnings;
+use strict;
+
+use Carp;
+use Params::Validate qw/:all/;
+use Test::Chimps;
+use LWP::UserAgent;
+use YAML::Syck;
+
+use constant PROTO_VERSION => 0.1;
+
+=head1 NAME
+
+Test::Chimps::Client - Send a Test::Chimps::Report to a server
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+=head1 SYNOPSIS
+
+This module simplifies the process of sending C<Test::Chimps::Report>s to a
+smoke server.
+
+ use Test::Chimps::Report;
+ use Test::Chimps::Client;
+ use Test::TAP::Model::Visual;
+
+ chdir "some/module/directory";
+
+ my $model = Test::TAP::Model::Visual->new_with_tests(glob("t/*.t"));
+
+ my $report = Test::Chimps::Report->new(model => $model);
+
+ my $client = Test::Chimps::Client->new(reports => [$report],
+ server => 'http://www.example.com/cgi-bin/smoke-server.pl');
+
+ my ($status, $msg) = $client->send;
+
+ if (! $status) {
+ print "Error: $msg\n";
+ exit(1);
+ }
+
+
+=head1 METHODS
+
+=head2 new ARGS
+
+Creates a new Client object. ARGS is a hash whose valid keys are:
+
+=over 4
+
+=item * compress
+
+Optional. Does not currently work
+
+=item * reports
+
+Mandatory. The value must be an array reference which contains
+C<Test::Chimps>s. These are the reports that will be
+submitted to the server.
+
+=item * server
+
+Mandatory. The URI of the server script to upload the reports to.
+
+=back
+
+=cut
+
+use base qw/Class::Accessor/;
+
+__PACKAGE__->mk_ro_accessors(qw/reports server compress/);
+
+sub new {
+ my $class = shift;
+ my $obj = bless {}, $class;
+ $obj->_init(@_);
+ return $obj;
+}
+
+sub _init {
+ my $self = shift;
+ validate_with(
+ params => \@_,
+ called => 'The Test::Chimps::Client constructor',
+ spec => {
+ reports => { type => ARRAYREF },
+ server => 1,
+ compress => 0
+ }
+ );
+
+ my %args = @_;
+ $self->{reports} = $args{reports};
+ foreach my $report (@{$self->{reports}}) {
+ croak "one the the specified reports is not a Test::Chimps::Report"
+ if ! (ref $report && $report->isa('Test::Chimps::Report'));
+ }
+ $self->{server} = $args{server};
+ $self->{compress} = $args{compress} || 0;
+}
+
+=head2 send
+
+Submit the specified reports to the server. This function's return
+value is a list, the first of which indicates success or failure,
+and the second of which is an error string.
+
+=cut
+
+sub send {
+ my $self = shift;
+
+ my $ua = LWP::UserAgent->new;
+ $ua->agent("Test-Chimps-Client/" . PROTO_VERSION);
+ $ua->env_proxy;
+
+ my $serialized_reports = [ map { Dump($_) } @{$self->reports} ];
+ my %request = (upload => 1, version => PROTO_VERSION,
+ reports => $serialized_reports);
+
+ my $resp = $ua->post($self->server => \%request);
+ if($resp->is_success) {
+ if($resp->content =~ /^ok/) {
+ return (1, '');
+ } else {
+ return (0, $resp->content);
+ }
+ } else {
+ return (0, $resp->status_line);
+ }
+}
+
+=head1 ACCESSORS
+
+There are read-only accessors for compress, reports, and server.
+
+=head1 AUTHOR
+
+Zev Benjamin, C<< <zev at cpan.org> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-test-chimps at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Chimps>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Chimps
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Test-Chimps>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Test-Chimps>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Chimps>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Test-Chimps>
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+The code in this distribution is based on smokeserv-client.pl and
+smokeserv-server.pl from the PUGS distribution.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2006 Zev Benjamin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
+
Added: Test-Chimps/branches/dbi/lib/Test/Chimps/Client/Poller.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/lib/Test/Chimps/Client/Poller.pm Mon Jul 3 18:18:52 2006
@@ -0,0 +1,446 @@
+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/;
+__PACKAGE__->mk_ro_accessors(qw/server config_file simulate/);
+__PACKAGE__->mk_accessors(
+ qw/_added_to_inc _env_stack _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->_env_stack([]);
+ $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;
+
+ $self->_unroll_env_stack;
+
+ 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 =>
+ { project => $project,
+ revision => $revision,
+ author => $author,
+ timestamp => scalar gmtime,
+ duration => $duration,
+ osname => $Config{osname},
+ osver => $Config{osver},
+ archname => $Config{archname}
+ });
+
+ my $client = Test::Chimps::Client->new(reports => [$report],
+ server => $self->server);
+
+ 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($self->config_file, $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);
+
+ $self->_push_onto_env_stack($project->{env});
+
+ 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;
+}
+
+sub _push_onto_env_stack {
+ my $self = shift;
+ my $vars = shift;
+
+ my $frame = {};
+ foreach my $var (keys %$vars) {
+ if (exists $ENV{$var}) {
+ $frame->{$var} = $ENV{$var};
+ } else {
+ $frame->{$var} = undef;
+ }
+ my $value = $vars->{$var};
+ # old value substitution
+ $value =~ s/\$$var/$ENV{$var}/g;
+
+ print "setting environment variable $var to $value\n";
+ $ENV{$var} = $value;
+ }
+ push @{$self->_env_stack}, $frame;
+}
+
+sub _unroll_env_stack {
+ my $self = shift;
+
+ while (scalar @{$self->_env_stack}) {
+ my $frame = pop @{$self->_env_stack};
+ foreach my $var (keys %$frame) {
+ if (defined $frame->{$var}) {
+ print "reverting environment variable $var to $frame->{$var}\n";
+ $ENV{$var} = $frame->{$var};
+ } else {
+ print "unsetting environment variable $var\n";
+ delete $ENV{$var};
+ }
+ }
+ }
+}
+
+=head1 ACCESSORS
+
+There are read-only accessors for server, config_file, simulate.
+
+=head1 CONFIGURATION FILE
+
+The configuration file is YAML dump of a hash. The keys at the top
+level of the hash are project names. Their values are hashes that
+comprise the configuration options for that project.
+
+Perhaps an example is best. A typical configuration file might
+look like this:
+
+ ---
+ Some-jifty-project:
+ configure_cmd: perl Makefile.PL --skipdeps && make
+ dependencies:
+ - Jifty
+ revision: 555
+ root_dir: trunk/foo
+ svn_uri: svn+ssh://svn.example.com/svn/foo
+ Jifty:
+ configure_cmd: perl Makefile.PL --skipdeps && make
+ dependencies:
+ - Jifty-DBI
+ revision: 1332
+ root_dir: trunk
+ svn_uri: svn+ssh://svn.jifty.org/svn/jifty.org/jifty
+ Jifty-DBI:
+ configure_cmd: perl Makefile.PL --skipdeps && make
+ env:
+ JDBI_TEST_MYSQL: jiftydbitestdb
+ JDBI_TEST_MYSQL_PASS: ''
+ JDBI_TEST_MYSQL_USER: jiftydbitest
+ JDBI_TEST_PG: jiftydbitestdb
+ JDBI_TEST_PG_USER: jiftydbitest
+ revision: 1358
+ root_dir: trunk
+ svn_uri: svn+ssh://svn.jifty.org/svn/jifty.org/Jifty-DBI
+
+The supported project options are as follows:
+
+=over 4
+
+=item * configure_cmd
+
+The command to configure the project after checkout, but before
+running tests.
+
+=item * revision
+
+This is the last revision known for a given project. When started,
+the poller will attempt to checkout and test all revisions (besides
+ones on which the directory did not change) between this one and
+HEAD. When a test has been successfully uploaded, the revision
+number is updated and the configuration file is re-written.
+
+=item * root_dir
+
+The subdirectory inside the repository where configuration and
+testing commands should be run.
+
+=item * svn_uri
+
+The subversion URI of the project.
+
+=item * env
+
+A hash of environment variable names and values that are set before
+configuration, and reverted to their previous values after the
+tests have been run. In addition, if environment variable FOO's
+new value contains the string "$FOO", then the old value of FOO
+will be substituted in when setting the environment variable.
+
+=item * dependencies
+
+A list of project names that are dependencies for the given
+project. All dependencies are checked out at HEAD, have their
+configuration commands run, and all dependencys' $root_dir/blib/lib
+directories are added to @INC before the configuration command for
+the project is run.
+
+=item * dependency_only
+
+Indicates that this project should not be tested. It is only
+present to serve as a dependency for another project.
+
+=back
+
+=head1 AUTHOR
+
+Zev Benjamin, C<< <zev at cpan.org> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-test-chimps at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Chimps>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Chimps
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Test-Chimps>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Test-Chimps>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Chimps>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Test-Chimps>
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+The code in this distribution is based on smokeserv-client.pl and
+smokeserv-server.pl from the PUGS distribution.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2006 Zev Benjamin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
Added: Test-Chimps/branches/dbi/lib/Test/Chimps/Report.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/lib/Test/Chimps/Report.pm Mon Jul 3 18:18:52 2006
@@ -0,0 +1,178 @@
+package Test::Chimps::Report;
+
+use warnings;
+use strict;
+
+use Carp;
+use Params::Validate qw/:all/;
+use Test::TAP::HTMLMatrix;
+use YAML::Syck;
+
+=head1 NAME
+
+Test::Chimps::Report - Encapsulate a smoke test report
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+=head1 SYNOPSIS
+
+This module encapsulates a L<Test::TAP::Model>'s structure and a
+freeform report text. If not provided, Test::TAP::HTMLMatrix will
+be used to generate the report.
+
+ use Test::Chimps::Report;
+ use Test::TAP::Model::Visual;
+
+ chdir "some/module/directory";
+
+ my $model = Test::TAP::Model::Visual->new_with_tests(glob("t/*.t"));
+
+ my $report = Test::Chimps::Report->new(model => $model);
+
+ ...
+
+=head1 METHODS
+
+=head2 new ARGS
+
+Creates a new Report. ARGS is a hash whose valid keys are:
+
+=over 4
+
+=item * model
+
+Mandatory and must be an instance of C<Test::Tap::Model>.
+
+=item * report_text
+
+A free-form report. If not supplied, it is filled in using
+C<Test::TAP::HTMLMatrix>, and C<extra_data> will be passed as the
+C<extra> argument to its constructor. Note that if you are using
+this class in conjunction with C<Test::Chimps::Server>,
+C<report_text> should probably be HTML.
+
+=item * report_variables
+
+Report variables to be transmitted with the report. The decision
+of which variables should be submitted is made by the server.
+
+=back
+
+=cut
+
+use base qw/Class::Accessor/;
+
+__PACKAGE__->mk_ro_accessors(
+ qw/model_structure
+ report_text report_variables/
+);
+
+
+sub new {
+ my $class = shift;
+ my $obj = bless {}, $class;
+ $obj->_init(@_);
+ return $obj;
+}
+
+sub _init {
+ my $self = shift;
+ validate_with(
+ params => \@_,
+ called => 'The Test::Chimps::Report constructor',
+ spec => {
+ model => { isa => 'Test::TAP::Model' },
+ report_text => 0,
+ report_variables => {
+ optional => 1,
+ type => HASHREF
+ }
+ }
+ );
+
+ my %args = @_;
+
+ $self->{model_structure} = $args{model}->structure;
+ if (defined $args{report_text}) {
+ $self->{report_text} = $args{report_text};
+ } else {
+ my $v;
+ if (defined $args{report_variables}) {
+ $v = Test::TAP::HTMLMatrix->new($args{model},
+ Dump($args{report_variables}));
+ $self->{report_variables} = $args{report_variables};
+ } else {
+ $v = Test::TAP::HTMLMatrix->new($args{model});
+ $self->{report_variables} = '';
+ }
+ $v->has_inline_css(1);
+ $self->{report_text} = $v->detail_html;
+ }
+}
+
+=head1 ACCESSORS
+
+There are read-only accessors for model_structure, report_text, and
+report_variables.
+
+=head1 AUTHOR
+
+Zev Benjamin, C<< <zev at cpan.org> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-test-chimps at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Chimps>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Chimps
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Test-Chimps>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Test-Chimps>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Chimps>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Test-Chimps>
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+The code in this distribution is based on smokeserv-client.pl and
+smokeserv-server.pl from the Pugs distribution.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2006 Zev Benjamin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
Added: Test-Chimps/branches/dbi/lib/Test/Chimps/Server.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/lib/Test/Chimps/Server.pm Mon Jul 3 18:18:52 2006
@@ -0,0 +1,449 @@
+package Test::Chimps::Server;
+
+use warnings;
+use strict;
+
+use Test::Chimps::Report;
+use Test::Chimps::Server::Lister;
+
+use Algorithm::TokenBucket;
+use CGI::Carp qw<fatalsToBrowser>;
+use CGI;
+use Digest::MD5 qw<md5_hex>;
+use File::Basename;
+use File::Spec;
+use Fcntl qw<:DEFAULT :flock>;
+use Params::Validate qw<:all>;
+use Storable qw<store_fd fd_retrieve freeze>;
+use YAML::Syck;
+
+use constant PROTO_VERSION => 0.1;
+
+=head1 NAME
+
+Test::Chimps::Server - Accept smoke report uploads and display smoke reports
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+=head1 SYNOPSIS
+
+This module simplifies the process of running a smoke server. It
+is meant to be used with Test::Chimps::Client.
+
+ use Test::Chimps::Server;
+
+ my $server = Test::Chimps::Server->new(base_dir => '/var/www/smokes');
+
+ $server->handle_request;
+
+=head1 METHODS
+
+=head2 new ARGS
+
+Creates a new Server object. ARGS is a hash whose valid keys are:
+
+=over 4
+
+=item * base_dir
+
+Mandatory. Base directory where report data will be stored.
+
+=item * bucket_file
+
+Name of bucket database file (see L<Algorithm::Bucket>). Defaults
+to 'bucket.dat'.
+
+=item * burst_rate
+
+Burst upload rate allowed (see L<Algorithm::Bucket>). Defaults to
+5.
+
+=item * list_template
+
+Template filename under base_dir/template_dir to use for listing
+smoke reports. Defaults to 'list.tmpl'.
+
+=item * lister
+
+An instance of L<Test::Chimps::Server::Lister> to use to list smoke
+reports. You do not have to use this option unless you are
+subclassing C<Lister>.
+
+=item * max_rate
+
+Maximum upload rate allowed (see L<Algorithm::Bucket>). Defaults
+to 1/30.
+
+=item * max_size
+
+Maximum size of HTTP POST that will be accepted. Defaults to 3
+MiB.
+
+=item * max_reports_per_subcategory
+
+Maximum number of smokes allowed per category. Defaults to 5.
+
+=item * report_dir
+
+Directory under base_dir where smoke reports will be stored.
+Defaults to 'reports'.
+
+=item * template_dir
+
+Directory under base_dir where html templates will be stored.
+Defaults to 'templates'.
+
+=item * variables_validation_spec
+
+A hash reference of the form accepted by Params::Validate. If
+supplied, this will be used to validate the report variables
+submitted to the server.
+
+=back
+
+=cut
+
+use base qw/Class::Accessor/;
+
+__PACKAGE__->mk_ro_accessors(
+ qw/base_dir bucket_file max_rate max_size
+ max_reports_per_subcategory report_dir
+ template_dir list_template lister
+ variables_validation_spec/
+);
+
+sub new {
+ my $class = shift;
+ my $obj = bless {}, $class;
+ $obj->_init(@_);
+ return $obj;
+}
+
+sub _init {
+ my $self = shift;
+ my %args = validate_with(
+ params => \@_,
+ called => 'The Test::Chimps::Server constructor',
+ spec => {
+ base_dir => {
+ type => SCALAR,
+ optional => 0
+ },
+ bucket_file => {
+ type => SCALAR,
+ default => 'bucket.dat',
+ optional => 1
+ },
+ burst_rate => {
+ type => SCALAR,
+ optional => 1,
+ default => 5,
+ callbacks => {
+ "greater than or equal to 0" => sub { $_[0] >= 0 }
+ }
+ },
+ variables_validation_spec => {
+ type => HASHREF,
+ optional => 1
+ },
+ list_template => {
+ type => SCALAR,
+ optional => 1,
+ default => 'list.tmpl'
+ },
+ lister => {
+ type => SCALAR,
+ isa => 'Test::Chimps::Server::Lister',
+ optional => 1
+ },
+ max_rate => {
+ type => SCALAR,
+ default => 1 / 30,
+ optional => 1,
+ callbacks => {
+ "greater than or equal to 0" => sub { $_[0] >= 0 }
+ }
+ },
+ max_size => {
+ type => SCALAR,
+ default => 2**20 * 3.0,
+ optional => 1,
+ callbacks => {
+ "greater than or equal to 0" => sub { $_[0] >= 0 }
+ }
+ },
+ max_reports_per_subcategory => {
+ type => SCALAR,
+ default => 5,
+ optional => 1,
+ callbacks => {
+ "greater than or equal to 0" => sub { $_[0] >= 0 }
+ }
+ },
+ report_dir => {
+ type => SCALAR,
+ default => 'reports',
+ optional => 1
+ },
+ template_dir => {
+ type => SCALAR,
+ default => 'templates',
+ optional => 1
+ }
+ }
+ );
+
+ foreach my $key (keys %args) {
+ $self->{$key} = $args{$key};
+ }
+}
+
+=head2 handle_request
+
+Handles a single request. This function will either accept a
+series of reports for upload or display report summaries.
+
+=cut
+
+sub handle_request {
+ my $self = shift;
+
+ my $cgi = CGI->new;
+ if ($cgi->param("upload")) {
+ $self->_process_upload($cgi);
+ } elsif ($cgi->param("id")) {
+ $self->_process_detail($cgi);
+ } else {
+ $self->_process_listing($cgi);
+ }
+}
+
+sub _process_upload {
+ my $self = shift;
+ my $cgi = shift;
+
+ print $cgi->header("text/plain");
+ $self->_limit_rate($cgi);
+ $self->_validate_params($cgi);
+ $self->_variables_validation_spec($cgi);
+ $self->_add_report($cgi);
+
+ print "ok";
+}
+
+sub _limit_rate {
+ my $self = shift;
+ my $cgi = shift;
+
+ my $bucket_file = File::Spec->catfile($self->{base_dir},
+ $self->{bucket_file});
+
+ # Open the DB and lock it exclusively. See perldoc -q lock.
+ sysopen my $fh, $bucket_file, O_RDWR|O_CREAT
+ or die "Couldn't open \"$bucket_file\": $!\n";
+ flock $fh, LOCK_EX
+ or die "Couldn't flock \"$bucket_file\": $!\n";
+
+ my $data = eval { fd_retrieve $fh };
+ $data ||= [$self->{max_rate}, $self->{burst_rate}];
+ my $bucket = Algorithm::TokenBucket->new(@$data);
+
+ my $exit;
+ unless($bucket->conform(1)) {
+ print "Rate limiting -- please wait a bit and try again, thanks.";
+ $exit++;
+ }
+ $bucket->count(1);
+
+ seek $fh, 0, 0 or die "Couldn't rewind \"$bucket_file\": $!\n";
+ truncate $fh, 0 or die "Couldn't truncate \"$bucket_file\": $!\n";
+
+ store_fd [$bucket->state] => $fh or
+ croak "Couldn't serialize bucket to \"$bucket_file\": $!\n";
+
+ exit if $exit;
+}
+
+sub _validate_params {
+ my $self = shift;
+ my $cgi = shift;
+
+ if(! $cgi->param("version") ||
+ $cgi->param("version") != PROTO_VERSION) {
+ print "Protocol versions do not match!";
+ exit;
+ }
+
+ if(! $cgi->param("reports")) {
+ print "No reports given!";
+ exit;
+ }
+
+# uncompress_smoke();
+}
+
+sub _variables_validation_spec {
+ my $self = shift;
+ my $cgi = shift;
+
+ my @reports = map { Load($_) } $cgi->param("reports");
+
+ if (defined $self->{variables_validation_spec}) {
+ foreach my $report (@reports) {
+ eval {
+ validate(@{[%{$report->{report_variables}}]}, $self->{variables_validation_spec});
+ };
+ if (defined $@ && $@) {
+ # XXX: doesn't dump subroutines because we're using YAML::Syck
+ print "This server accepts specific report variables. It's validation ",
+ "string looks like this:\n", Dump($self->{variables_validation_spec}),
+ "\nYour extra data looks like this:\n", Dump($report->{report_variables});
+ exit;
+ }
+
+ }
+ }
+}
+
+sub _add_report {
+ my $self = shift;
+ my $cgi = shift;
+
+ my @reports = $cgi->param("reports");
+
+ foreach my $report (@reports) {
+ my $id = md5_hex $report;
+
+ my $report_file = File::Spec->catfile($self->{base_dir},
+ $self->{report_dir},
+ $id . ".yml");
+ if (-e $report_file) {
+ print "One of the submitted reports was already submitted!";
+ exit;
+ }
+
+ open my $fh, ">", $report_file or
+ croak "Couldn't open \"$report_file\" for writing: $!\n";
+ print $fh $report or
+ croak "Couldn't write to \"$report_file\": $!\n";
+ close $fh or
+ croak "Couldn't close \"$report_file\": $!\n";
+ }
+}
+
+sub _process_detail {
+ my $self = shift;
+ my $cgi = shift;
+
+ print $cgi->header;
+
+ my $id = $cgi->param("id");
+
+ unless ($id =~ m/^[a-f0-9]+$/i) {
+ print "Invalid id: $id";
+ exit;
+ }
+
+ my $report = LoadFile(File::Spec->catfile($self->{base_dir},
+ $self->{report_dir},
+ $id . ".yml"));
+
+ print $report->report_text;
+}
+
+sub _process_listing {
+ my $self = shift;
+ my $cgi = shift;
+
+ print $cgi->header();
+
+ my @files = glob File::Spec->catfile($self->{base_dir},
+ $self->{report_dir},
+ "*.yml");
+
+ my @reports = map { LoadFile($_) } @files;
+
+ # XXX FIXME we shouldn't just be adding this stuff here
+ for (my $i = 0; $i < scalar @reports ; $i++) {
+ my ($filename, $directories, $suffix) = fileparse($files[$i], '.yml');
+ $reports[$i]->{url} = $cgi->url . "?id=$filename";
+ $reports[$i]->{id} = $filename;
+ }
+
+ my $lister;
+ if (defined $self->lister) {
+ $lister = $self->lister;
+ } else {
+ $lister = Test::Chimps::Server::Lister->new(
+ list_template => $self->list_template,
+ max_reports_per_subcategory => $self->max_reports_per_subcategory
+ );
+ }
+
+ $lister->output_list(File::Spec->catdir($self->{base_dir},
+ $self->{template_dir}),
+ \@reports);
+
+}
+
+=head1 AUTHOR
+
+Zev Benjamin, C<< <zev at cpan.org> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-test-chimps at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Chimps>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Chimps
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Test-Chimps>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Test-Chimps>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Chimps>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Test-Chimps>
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+The code in this distribution is based on smokeserv-client.pl and
+smokeserv-server.pl from the PUGS distribution.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2006 Zev Benjamin, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
Added: Test-Chimps/branches/dbi/lib/Test/Chimps/Server/Lister.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/lib/Test/Chimps/Server/Lister.pm Mon Jul 3 18:18:52 2006
@@ -0,0 +1,165 @@
+package Test::Chimps::Server::Lister;
+
+use warnings;
+use strict;
+
+use Params::Validate qw<:all>;
+use Test::Chimps::Report;
+use HTML::Mason;
+use DateTime;
+use Date::Parse;
+
+=head1 NAME
+
+Test::Chimps::Server::Lister - Format the list of smoke reports
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+=head1 SYNOPSIS
+
+This module encapsulates the formatting and output of the smoke
+report list. You should not have to use this module directly
+unless you need to customize listing output. To do so, subclass
+C<Lister> and pass one to your C<Server>.
+
+ package MyLister;
+
+ use base 'Test::Chimps::Server::Lister';
+
+ sub foo { ... }
+
+ package main;
+
+ use Test::Chimps::Server;
+
+ my $lister = MyLister->new();
+
+ my $server = Test::Chimps::Server->new(
+ base_dir => '/var/www/smokes',
+ lister => $lister
+ );
+
+ $server->handle_request;
+
+=head1 METHODS
+
+=cut
+
+use base qw/Class::Accessor/;
+
+__PACKAGE__->mk_ro_accessors(
+ qw/max_reports_per_subcategory list_template/
+);
+
+
+sub new {
+ my $class = shift;
+ my $obj = bless {}, $class;
+ $obj->_init(@_);
+ return $obj;
+}
+
+sub _init {
+ my $self = shift;
+ my %args = validate_with(
+ params => \@_,
+ called => 'The Test::Chimps::Server::Lister constructor',
+ spec => {
+ list_template => {
+ type => SCALAR,
+ optional => 0,
+ },
+ max_reports_per_subcategory => {
+ type => SCALAR,
+ optional => 0
+ }
+ }
+ );
+
+ foreach my $key (keys %args) {
+ $self->{$key} = $args{$key};
+ }
+}
+
+sub output_list {
+ my ($self, $template_dir, $reports) = @_;
+
+ my $interp = HTML::Mason::Interp->new(comp_root => $template_dir);
+
+ my $categories = $self->_build_heirarchy($reports);
+
+ $interp->exec(File::Spec->catfile(File::Spec->rootdir,
+ $self->list_template),
+ categories => $categories);
+}
+
+sub _build_heirarchy {
+ my $self = shift;
+ my $reports = shift;
+
+ my $categories = {};
+ foreach my $report (@$reports) {
+ my $category = $self->_compute_category($report);
+ my $subcategory = $self->_compute_subcategory($report);
+ push @{$categories->{$category}->{$subcategory}}, $report;
+ }
+ $self->_sort_reports($categories);
+ $self->_prune_reports($categories);
+ return $categories;
+}
+
+sub _compute_category {
+ my $self = shift;
+ my $report = shift;
+ return $report->report_variables->{project};
+}
+
+sub _compute_subcategory {
+ my $self = shift;
+ my $report = shift;
+ return '';
+}
+
+sub _sort_reports {
+ my $self = shift;
+ my $categories = shift;
+
+ foreach my $category (keys %$categories) {
+ foreach my $subcategory (keys %{$categories->{$category}}) {
+ @{$categories->{$category}->{$subcategory}} =
+ sort _by_revision_then_date @{$categories->{$category}->{$subcategory}};
+ }
+ }
+}
+
+sub _by_revision_then_date {
+ my $res = $b->report_variables->{revision} <=> $a->report_variables->{revision};
+
+ if ($res != 0) {
+ return $res;
+ }
+
+ my ($adate, $bdate) = (DateTime->from_epoch(epoch => str2time($a->report_variables->{timestamp})),
+ DateTime->from_epoch(epoch => str2time($b->report_variables->{timestamp})));
+ return DateTime->compare($bdate, $adate);
+}
+
+sub _prune_reports {
+ my $self = shift;
+ my $categories = shift;
+
+ foreach my $category (keys %$categories) {
+ foreach my $subcategory (keys %{$categories->{$category}}) {
+ @{$categories->{$category}->{$subcategory}} =
+ @{$categories->{$category}->{$subcategory}}[0 .. ($self->max_reports_per_subcategory - 1)];
+ }
+ }
+}
+
+1;
Added: Test-Chimps/branches/dbi/t/00-dependencies.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/t/00-dependencies.t Mon Jul 3 18:18:52 2006
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::Dependencies exclude => [qw/Test::Chimps/];
+
+ok_dependencies();
+
Added: Test-Chimps/branches/dbi/t/01-report-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/t/01-report-basic.t Mon Jul 3 18:18:52 2006
@@ -0,0 +1,19 @@
+#!perl -T
+
+use Test::More tests => 5;
+
+BEGIN {
+ use_ok( 'Test::Chimps::Report' );
+}
+
+use Test::TAP::Model::Visual;
+
+my $m = Test::TAP::Model::Visual->new_with_tests('t/bogus-tests/00-basic.t');
+
+# Test::Harness::Straps breaks under taint mode, so Test::TAP::Model also breaks
+my $r = Test::Chimps::Report->new(model => $m, report_text => "foo");
+ok($r, "the report object is defined");
+isa_ok($r, 'Test::Chimps::Report', "and it's of the correct type");
+
+is($r->model_structure, $m->structure, "the model_structure accessor works");
+is($r->report_text, "foo", "the report_text accessor works");
Added: Test-Chimps/branches/dbi/t/05-client-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/t/05-client-basic.t Mon Jul 3 18:18:52 2006
@@ -0,0 +1,27 @@
+#!perl -T
+
+use Test::More tests => 6;
+
+use Test::Chimps::Report;
+use Test::TAP::Model::Visual;
+
+BEGIN {
+ use_ok( 'Test::Chimps::Client' );
+}
+
+my $m = Test::TAP::Model::Visual->new_with_tests('t/bogus-tests/00-basic.t');
+
+# Test::Harness::Straps breaks under taint mode, so Test::TAP::Model also breaks
+my $r = Test::Chimps::Report->new(model => $m, report_text => "foo");
+
+my $reports = [$r];
+my $c = Test::Chimps::Client->new(reports => $reports,
+ server => 'bogus',
+ compress => 1);
+
+ok($c, "the client object is defined");
+isa_ok($c, 'Test::Chimps::Client', "and it's of the correct type");
+
+is($c->reports, $reports, "the reports accessor works");
+is($c->server, "bogus", "the server accessor works");
+is($c->compress, 1, "the compress accessor works");
Added: Test-Chimps/branches/dbi/t/10-server-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/t/10-server-basic.t Mon Jul 3 18:18:52 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/branches/dbi/t/15-poller-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/t/15-poller-basic.t Mon Jul 3 18:18:52 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");
Added: Test-Chimps/branches/dbi/t/20-lister-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/t/20-lister-basic.t Mon Jul 3 18:18:52 2006
@@ -0,0 +1,13 @@
+#!perl -T
+
+use Test::More tests => 3;
+
+BEGIN {
+ use_ok('Test::Chimps::Server::Lister');
+}
+
+my $s = Test::Chimps::Server::Lister->new(list_template => 'bogus',
+ max_reports_per_subcategory => 10);
+
+ok($s, "the server object is defined");
+isa_ok($s, 'Test::Chimps::Server::Lister', "and it's of the correct type");
Added: Test-Chimps/branches/dbi/t/bogus-tests/00-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/t/bogus-tests/00-basic.t Mon Jul 3 18:18:52 2006
@@ -0,0 +1,9 @@
+#!perl -T
+
+use Test::More tests => 3;
+
+is(1, 1);
+
+ok(1+1 == 2);
+
+isnt(2+2, 5);
Added: Test-Chimps/branches/dbi/t/boilerplate.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/t/boilerplate.t Mon Jul 3 18:18:52 2006
@@ -0,0 +1,50 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More tests => 5;
+
+sub not_in_file_ok {
+ my ($filename, %regex) = @_;
+ open my $fh, "<", $filename
+ or die "couldn't open $filename for reading: $!";
+
+ my %violated;
+
+ while (my $line = <$fh>) {
+ while (my ($desc, $regex) = each %regex) {
+ if ($line =~ $regex) {
+ push @{$violated{$desc}||=[]}, $.;
+ }
+ }
+ }
+
+ if (%violated) {
+ fail("$filename contains boilerplate text");
+ diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
+ } else {
+ pass("$filename contains no boilerplate text");
+ }
+}
+
+not_in_file_ok(README =>
+ "The README is used..." => qr/The README is used/,
+ "'version information here'" => qr/to provide version information/,
+);
+
+not_in_file_ok(Changes =>
+ "placeholder date/time" => qr(Date/time)
+);
+
+sub module_boilerplate_ok {
+ my ($module) = @_;
+ not_in_file_ok($module =>
+ 'the great new $MODULENAME' => qr/ - The great new /,
+ 'boilerplate description' => qr/Quick summary of what the module/,
+ 'stub function definition' => qr/function[12]/,
+ );
+}
+
+module_boilerplate_ok('lib/Test/Chimps/Report.pm');
+module_boilerplate_ok('lib/Test/Chimps/Client.pm');
+module_boilerplate_ok('lib/Test/Chimps/Server.pm');
Added: Test-Chimps/branches/dbi/t/pod-coverage.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/t/pod-coverage.t Mon Jul 3 18:18:52 2006
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
+all_pod_coverage_ok();
Added: Test-Chimps/branches/dbi/t/pod.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/dbi/t/pod.t Mon Jul 3 18:18:52 2006
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+all_pod_files_ok();
More information about the Rt-commit
mailing list