[Rt-commit] r5477 - in Test-Chimps: branches/categories-rework branches/categories-rework/bin branches/categories-rework/examples branches/categories-rework/lib branches/categories-rework/lib/Test branches/categories-rework/lib/Test/Chimps branches/categories-rework/lib/Test/Chimps/Client branches/categories-rework/t branches/categories-rework/t/bogus-tests

zev at bestpractical.com zev at bestpractical.com
Tue Jun 27 19:28:44 EDT 2006


Author: zev
Date: Tue Jun 27 19:28:42 2006
New Revision: 5477

Added:
   Test-Chimps/branches/categories-rework/
   Test-Chimps/branches/categories-rework/Changes
   Test-Chimps/branches/categories-rework/MANIFEST
   Test-Chimps/branches/categories-rework/Makefile.PL
   Test-Chimps/branches/categories-rework/README
   Test-Chimps/branches/categories-rework/TODO
   Test-Chimps/branches/categories-rework/bin/
   Test-Chimps/branches/categories-rework/bin/poll_and_submit.pl   (contents, props changed)
   Test-Chimps/branches/categories-rework/bin/report_server.pl   (contents, props changed)
   Test-Chimps/branches/categories-rework/bin/submit_report.pl   (contents, props changed)
   Test-Chimps/branches/categories-rework/examples/
   Test-Chimps/branches/categories-rework/examples/list.tmpl
   Test-Chimps/branches/categories-rework/lib/
   Test-Chimps/branches/categories-rework/lib/Test/
   Test-Chimps/branches/categories-rework/lib/Test/Chimps/
   Test-Chimps/branches/categories-rework/lib/Test/Chimps.pm
   Test-Chimps/branches/categories-rework/lib/Test/Chimps/Client/
   Test-Chimps/branches/categories-rework/lib/Test/Chimps/Client.pm
   Test-Chimps/branches/categories-rework/lib/Test/Chimps/Client/Poller.pm
   Test-Chimps/branches/categories-rework/lib/Test/Chimps/Report.pm
   Test-Chimps/branches/categories-rework/lib/Test/Chimps/Server.pm
   Test-Chimps/branches/categories-rework/t/
   Test-Chimps/branches/categories-rework/t/00-dependencies.t
   Test-Chimps/branches/categories-rework/t/01-report-basic.t
   Test-Chimps/branches/categories-rework/t/05-client-basic.t
   Test-Chimps/branches/categories-rework/t/10-server-basic.t
   Test-Chimps/branches/categories-rework/t/15-poller-basic.t
   Test-Chimps/branches/categories-rework/t/bogus-tests/
   Test-Chimps/branches/categories-rework/t/bogus-tests/00-basic.t
   Test-Chimps/branches/categories-rework/t/boilerplate.t
   Test-Chimps/branches/categories-rework/t/pod-coverage.t
   Test-Chimps/branches/categories-rework/t/pod.t
Modified:
   Test-Chimps/   (props changed)

Log:
 r9750 at galvatron:  zev | 2006-06-26 18:14:06 -0400
 svk-commitoDPPy.tmp


Added: Test-Chimps/branches/categories-rework/Changes
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/Changes	Tue Jun 27 19:28:42 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/categories-rework/MANIFEST
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/MANIFEST	Tue Jun 27 19:28:42 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/categories-rework/Makefile.PL
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/Makefile.PL	Tue Jun 27 19:28:42 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/categories-rework/README
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/README	Tue Jun 27 19:28:42 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/categories-rework/TODO
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/TODO	Tue Jun 27 19:28:42 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/categories-rework/bin/poll_and_submit.pl
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/bin/poll_and_submit.pl	Tue Jun 27 19:28:42 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/categories-rework/bin/report_server.pl
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/bin/report_server.pl	Tue Jun 27 19:28:42 2006
@@ -0,0 +1,15 @@
+#!/usr/bin/env perl
+
+use Test::Chimps::Server;
+
+my $server = Test::Chimps::Server->new(base_dir => '/var/www/bps-smokes',
+                                       variables_validation_spec =>
+                                       { category => 1,
+                                         subcategory => 1,
+                                         project => 1,
+                                         revision => 1,
+                                         author => 1,
+                                         timestamp => 1,
+                                         duration => 1 });
+
+$server->handle_request;

Added: Test-Chimps/branches/categories-rework/bin/submit_report.pl
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/bin/submit_report.pl	Tue Jun 27 19:28:42 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/categories-rework/examples/list.tmpl
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/examples/list.tmpl	Tue Jun 27 19:28:42 2006
@@ -0,0 +1,147 @@
+<?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 = "&laquo;";
+      } else {
+	elem.className = "details";
+	expander.innerHTML = "&raquo;";
+      }
+    }
+  //]]></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 (sort by_revision_then_date
+%                          @{$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} %>&nbsp;sec</td>
+            <td class="leftsep num"><% sprintf("%.2f", $model->total_ratio * 100) %>%&nbsp;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 %>">&raquo;</span></td>
+	    <td><a style="text-decoration: none" href="<% $report->{url} %>" title="Full smoke report">&raquo;</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>
+$report_dir
+ at reports
+</%args>
+
+<%init>
+use DateTime;
+use Date::Parse;
+
+my %categories;
+foreach my $report (@reports) {
+  my $data = $report->report_variables;
+  push @{$categories{$data->{category}}->{$data->{subcategory}}}, $report;
+}
+
+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);
+}
+</%init>

Added: Test-Chimps/branches/categories-rework/lib/Test/Chimps.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/lib/Test/Chimps.pm	Tue Jun 27 19:28:42 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/categories-rework/lib/Test/Chimps/Client.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/lib/Test/Chimps/Client.pm	Tue Jun 27 19:28:42 2006
@@ -0,0 +1,199 @@
+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 => \@_,
+                spec => 
+                { reports =>
+                  { type => ARRAYREF },
+                  server => 1,
+                  compress => 0},
+                called => 'The Test::Chimps::Client constructor');
+  
+  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/categories-rework/lib/Test/Chimps/Client/Poller.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/lib/Test/Chimps/Client/Poller.pm	Tue Jun 27 19:28:42 2006
@@ -0,0 +1,444 @@
+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 =>
+                                               { 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 => $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/categories-rework/lib/Test/Chimps/Report.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/lib/Test/Chimps/Report.pm	Tue Jun 27 19:28:42 2006
@@ -0,0 +1,176 @@
+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 => \@_,
+                spec =>
+                { model =>
+                  {
+                   isa => 'Test::TAP::Model'},
+                  report_text => 0,
+                  report_variables =>
+                  { optional => 1,
+                    type => HASHREF } },
+                called => 'The Test::Chimps::Report constructor');
+
+  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/categories-rework/lib/Test/Chimps/Server.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/lib/Test/Chimps/Server.pm	Tue Jun 27 19:28:42 2006
@@ -0,0 +1,424 @@
+package Test::Chimps::Server;
+
+use warnings;
+use strict;
+
+use Test::Chimps::Report;
+
+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 HTML::Mason;
+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 * 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_smokes_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_smokes_per_subcategory report_dir
+    template_dir list_template 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' },
+       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_smokes_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);
+  $self->_clean_old_reports($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 _clean_old_reports {
+  # XXX: stub
+}
+
+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;
+
+  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 $interp = HTML::Mason::Interp->new(comp_root =>
+                                        File::Spec->catfile($self->{base_dir},
+                                                            $self->{template_dir}));
+  $interp->exec(File::Spec->catfile(File::Spec->rootdir,
+                                    $self->{list_template}),
+                report_dir => $self->{http_report_dir},
+                reports => \@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/categories-rework/t/00-dependencies.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/t/00-dependencies.t	Tue Jun 27 19:28:42 2006
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::Dependencies exclude => [qw/Test::Chimps/];
+
+ok_dependencies();
+

Added: Test-Chimps/branches/categories-rework/t/01-report-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/t/01-report-basic.t	Tue Jun 27 19:28:42 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/categories-rework/t/05-client-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/t/05-client-basic.t	Tue Jun 27 19:28:42 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/categories-rework/t/10-server-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/t/10-server-basic.t	Tue Jun 27 19:28:42 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/categories-rework/t/15-poller-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/t/15-poller-basic.t	Tue Jun 27 19:28:42 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/categories-rework/t/bogus-tests/00-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/t/bogus-tests/00-basic.t	Tue Jun 27 19:28:42 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/categories-rework/t/boilerplate.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/t/boilerplate.t	Tue Jun 27 19:28:42 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/categories-rework/t/pod-coverage.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/t/pod-coverage.t	Tue Jun 27 19:28:42 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/categories-rework/t/pod.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/t/pod.t	Tue Jun 27 19:28:42 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