[Rt-commit] r5429 - in Test-Chimps: . trunk trunk/bin trunk/lib/Test trunk/lib/Test/Chimps trunk/t

zev at bestpractical.com zev at bestpractical.com
Fri Jun 23 17:33:32 EDT 2006


Author: zev
Date: Fri Jun 23 17:33:29 2006
New Revision: 5429

Added:
   Test-Chimps/trunk/lib/Test/Chimps/
   Test-Chimps/trunk/lib/Test/Chimps.pm
   Test-Chimps/trunk/lib/Test/Chimps/Client.pm
   Test-Chimps/trunk/lib/Test/Chimps/Report.pm
   Test-Chimps/trunk/lib/Test/Chimps/Server.pm
Removed:
   Test-Chimps/trunk/lib/Test/Smoke/
Modified:
   Test-Chimps/   (props changed)
   Test-Chimps/trunk/Changes
   Test-Chimps/trunk/MANIFEST
   Test-Chimps/trunk/Makefile.PL
   Test-Chimps/trunk/README
   Test-Chimps/trunk/bin/poll_and_submit.pl
   Test-Chimps/trunk/bin/report_server.pl
   Test-Chimps/trunk/bin/submit_report.pl
   Test-Chimps/trunk/t/00-dependencies.t
   Test-Chimps/trunk/t/01-report-basic.t
   Test-Chimps/trunk/t/05-client-basic.t
   Test-Chimps/trunk/t/10-server-base.t
   Test-Chimps/trunk/t/boilerplate.t

Log:
 r4195 at galvatron (orig r10):  zev | 2006-06-20 22:07:34 -0400
  r4194 at galvatron:  zev | 2006-06-20 22:07:28 -0400
  great module rename
 


Modified: Test-Chimps/trunk/Changes
==============================================================================
--- Test-Chimps/trunk/Changes	(original)
+++ Test-Chimps/trunk/Changes	Fri Jun 23 17:33:29 2006
@@ -1,6 +1,5 @@
-Revision history for Test-Smoke-Report
+Revision history for Test-Chimps
 
 0.01    Fri Jun 16 13:21:11 EDT 2006
-        First revision.  Test::Smoke::Report and
-        Test::Smoke::Report::Client are both functional.
+        First revision.  
 

Modified: Test-Chimps/trunk/MANIFEST
==============================================================================
--- Test-Chimps/trunk/MANIFEST	(original)
+++ Test-Chimps/trunk/MANIFEST	Fri Jun 23 17:33:29 2006
@@ -3,8 +3,16 @@
 META.yml # Will be created by "make dist"
 Makefile.PL
 README
-lib/Test/Smoke/Report.pm
-t/00-load.t
+lib/Test/Chimps/Report.pm
+lib/Test/Chimps/Client.pm
+lib/Test/Chimps/Server.pm
+t
+t/bogus-tests
+t/bogus-tests/00-basic.t
+t/05-client-basic.t
 t/boilerplate.t
-t/pod-coverage.t
 t/pod.t
+t/00-dependencies.t
+t/01-report-basic.t
+t/pod-coverage.t
+t/10-server-base.t

Modified: Test-Chimps/trunk/Makefile.PL
==============================================================================
--- Test-Chimps/trunk/Makefile.PL	(original)
+++ Test-Chimps/trunk/Makefile.PL	Fri Jun 23 17:33:29 2006
@@ -1,8 +1,8 @@
 use inc::Module::Install;
 
 # Define metadata
-name            'Test-Smoke-Report';
-all_from        'lib/Test/Smoke/Report.pm';
+name            'Test-Chimps';
+all_from        'lib/Test/Chimps.pm';
 
 # Specific dependencies
 requires('Algorithm::TokenBucket');

Modified: Test-Chimps/trunk/README
==============================================================================
--- Test-Chimps/trunk/README	(original)
+++ Test-Chimps/trunk/README	Fri Jun 23 17:33:29 2006
@@ -1,4 +1,4 @@
-Test-Smoke-Report
+Test-Chimps
 
 This module modularizes the pugs smoke server/client
 (smokeserv-client.pl and smokeserv-server.pl).  It also makes the
@@ -20,21 +20,21 @@
 
 After installing, you can find documentation for this module with the perldoc command.
 
-    perldoc Test::Smoke::Report
+    perldoc Test::Chimps
 
 You can also look for information at:
 
     Search CPAN
-        http://search.cpan.org/dist/Test-Smoke-Report
+        http://search.cpan.org/dist/Test-Chimps
 
     CPAN Request Tracker:
-        http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Smoke-Report
+        http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Chimps
 
     AnnoCPAN, annotated CPAN documentation:
-        http://annocpan.org/dist/Test-Smoke-Report
+        http://annocpan.org/dist/Test-Chimps
 
     CPAN Ratings:
-        http://cpanratings.perl.org/d/Test-Smoke-Report
+        http://cpanratings.perl.org/d/Test-Chimps
 
 COPYRIGHT AND LICENCE
 

Modified: Test-Chimps/trunk/bin/poll_and_submit.pl
==============================================================================
--- Test-Chimps/trunk/bin/poll_and_submit.pl	(original)
+++ Test-Chimps/trunk/bin/poll_and_submit.pl	Fri Jun 23 17:33:29 2006
@@ -3,8 +3,8 @@
 use warnings;
 use strict;
 
-use Test::Smoke::Report;
-use Test::Smoke::Report::Client;
+use Test::Chimps::Report;
+use Test::Chimps::Client;
 use Test::TAP::Model::Visual;
 use YAML::Syck;
 use File::Basename;

Modified: Test-Chimps/trunk/bin/report_server.pl
==============================================================================
--- Test-Chimps/trunk/bin/report_server.pl	(original)
+++ Test-Chimps/trunk/bin/report_server.pl	Fri Jun 23 17:33:29 2006
@@ -1,17 +1,15 @@
 #!/usr/bin/env perl
 
-use lib '/home/zev/bps/Test-Smoke-Report/trunk/lib';
+use Test::Chimps::Server;
 
-use Test::Smoke::Report::Server;
-
-my $server = Test::Smoke::Report::Server->new(base_dir => '/var/www/bps-smokes',
-                                              extra_validation_spec =>
-                                              { category => 1,
-                                                subcategory => 1,
-                                                project => 1,
-                                                revision => 1,
-                                                author => 1,
-                                                timestamp => 1,
-                                                duration => 1 });
+my $server = Test::Chimps::Server->new(base_dir => '/var/www/bps-smokes',
+                                       extra_validation_spec =>
+                                       { category => 1,
+                                         subcategory => 1,
+                                         project => 1,
+                                         revision => 1,
+                                         author => 1,
+                                         timestamp => 1,
+                                         duration => 1 });
 
 $server->handle_request;

Modified: Test-Chimps/trunk/bin/submit_report.pl
==============================================================================
--- Test-Chimps/trunk/bin/submit_report.pl	(original)
+++ Test-Chimps/trunk/bin/submit_report.pl	Fri Jun 23 17:33:29 2006
@@ -3,11 +3,9 @@
 use warnings;
 use strict;
 
-use lib '/home/zev/bps/Test-Smoke-Report/trunk/lib';
-
 use Getopt::Long;
-use Test::Smoke::Report;
-use Test::Smoke::Report::Client;
+use Test::Chimps::Report;
+use Test::Chimps::Client;
 use Test::TAP::Model::Visual;
 
 chdir "jifty/trunk";
@@ -16,17 +14,17 @@
 my $model = Test::TAP::Model::Visual->new_with_tests(glob("t/*.t t/*/t/*.t"));
 my $duration = time - $start_time;
 
-my $report = Test::Smoke::Report->new(model => $model,
-                                      extra_data =>
-                                      { category => 'Jifty',
-                                        subcategory => 'repository snapshot / Linux',
-                                        project => 'jifty',
-                                        revision => 5,
-                                        timestamp => scalar gmtime,
-                                        duration => $duration });
+my $report = Test::Chimps::Report->new(model => $model,
+                                       extra_data =>
+                                       { category => 'Jifty',
+                                         subcategory => 'repository snapshot / Linux',
+                                         project => 'jifty',
+                                         revision => 5,
+                                         timestamp => scalar gmtime,
+                                         duration => $duration });
 
-my $client = Test::Smoke::Report::Client->new(reports => [$report],
-                                              server => 'http://galvatron.mit.edu/cgi-bin/report_server.pl');
+my $client = Test::Chimps::Client->new(reports => [$report],
+                                       server => 'http://galvatron.mit.edu/cgi-bin/report_server.pl');
 
 my ($status, $msg) = $client->send;
 

Added: Test-Chimps/trunk/lib/Test/Chimps.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/trunk/lib/Test/Chimps.pm	Fri Jun 23 17:33:29 2006
@@ -0,0 +1,78 @@
+=head1 NAME
+
+Test::Chimps - Collaborative Heterogeneous Infinite Monkey Perfection Service
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+=head1 SYNOPSIS
+
+The Collaborative Heterogeneous Infinite Monkey Perfection 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 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/trunk/lib/Test/Chimps/Client.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/trunk/lib/Test/Chimps/Client.pm	Fri Jun 23 17:33:29 2006
@@ -0,0 +1,224 @@
+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>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 * 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.
+
+=item * compress
+
+Optional.  Does not currently work
+
+=back
+
+=cut
+
+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"
+      if ! (ref $report && $report->isa('Test::Chimps'));
+  }
+  $self->{server} = $args{server};
+  $self->{compress} = $args{compress} || 0;
+}
+
+=head2 reports
+
+Accessor for the reports to be submitted.
+
+=cut
+
+sub reports {
+  my $self = shift;
+  return $self->{reports};
+}
+
+=head2 server
+
+Accessor for the submission server.
+
+=cut
+
+sub server {
+  my $self = shift;
+  return $self->{server};
+}
+
+=head2 compress
+
+Accessor for whether compression is turned on.
+
+=cut
+
+sub compress {
+  my $self = shift;
+  return $self->{compress};
+}
+
+=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 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/trunk/lib/Test/Chimps/Report.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/trunk/lib/Test/Chimps/Report.pm	Fri Jun 23 17:33:29 2006
@@ -0,0 +1,194 @@
+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::Smoke::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 * extra_data
+
+Extra data to be transmitted with the report.  
+
+=back
+
+=cut
+
+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,
+                  extra_data =>
+                  { 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{extra_data}) {
+      $v = Test::TAP::HTMLMatrix->new($args{model},
+                                      Dump($args{extra_data}));
+      $self->{extra_data} = $args{extra_data};
+    } else {
+      $v = Test::TAP::HTMLMatrix->new($args{model});
+      $self->{extra_data} = '';
+    }
+    $v->has_inline_css(1);
+    $self->{report_text} = $v->detail_html;
+  }
+}
+
+=head2 model_structure
+
+Accessor for the passed-in model's structure.
+
+=cut
+
+sub model_structure {
+  my $self = shift;
+  return $self->{model_structure};
+}
+
+=head2 report_text
+
+Accessor for the report text.
+
+=cut
+
+sub report_text {
+  my $self = shift;
+  return $self->{report_text};
+}
+
+=head2 extra_data
+
+Accessor for any extra data passed in.
+
+=cut
+
+sub extra_data {
+  my $self = shift;
+  return $self->{extra_data};
+}
+
+=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/trunk/lib/Test/Chimps/Server.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/trunk/lib/Test/Chimps/Server.pm	Fri Jun 23 17:33:29 2006
@@ -0,0 +1,435 @@
+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 * extra_validation_spec
+
+A hash reference of the form accepted by Params::Validate.  If
+supplied, this will be used to validate the extra data submitted to
+the server.
+
+=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'.
+
+=back
+
+=cut
+
+{
+  no strict 'refs';
+  our @fields = qw/base_dir bucket_file max_rate max_size
+                   max_smokes_per_subcategory report_dir
+                   template_dir list_template extra_validation_spec/;
+
+  foreach my $field (@fields) {
+    *{$field} =
+      sub {
+        my $self = shift;
+        return $self->{$field};
+      };
+  }
+} 
+
+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 }} },
+       extra_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 }} },
+       pre_add_hook =>
+       { type => CODEREF,
+         optional => 1 },
+       report_dir =>
+       { type => SCALAR,
+         default => 'reports',
+         optional => 1 },
+       template_dir =>
+       { type => SCALAR,
+         default => 'templates',
+         optional => 1 }
+     });
+  
+  foreach my $key (%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->_extra_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 _extra_validation_spec {
+  my $self = shift;
+  my $cgi = shift;
+  
+  my @reports = map { Load($_) } $cgi->param("reports");
+  
+  if (defined $self->{extra_validation_spec}) {
+    foreach my $report (@reports) {
+      eval {
+        validate(@{[%{$report->{extra_data}}]}, $self->{extra_validation_spec});
+      };
+      if (defined $@ && $@) {
+        # XXX: doesn't dump subroutines because we're using YAML::Syck
+        print "This server accepts extra parameters.  It's validation ",
+          "string looks like this:\n", Dump($self->{extra_validation_spec}),
+          "\nYour extra data looks like this:\n", Dump($report->{extra_data});
+        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 { bless LoadFile($_), 'Test::Chimps::Report' }
+    @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;

Modified: Test-Chimps/trunk/t/00-dependencies.t
==============================================================================
--- Test-Chimps/trunk/t/00-dependencies.t	(original)
+++ Test-Chimps/trunk/t/00-dependencies.t	Fri Jun 23 17:33:29 2006
@@ -49,7 +49,7 @@
 for (sort keys %used) {
     my $first_in = Module::CoreList->first_release($_);
     next if defined $first_in and $first_in <= 5.00803;
-    next if /^(Test::Smoke::Report)(::|$)/;
+    next if /^(Test::Chimps)(::|$)/;
     ok(exists $required{$_}, "$_ in Makefile.PL");
     delete $used{$_};
     delete $required{$_};

Modified: Test-Chimps/trunk/t/01-report-basic.t
==============================================================================
--- Test-Chimps/trunk/t/01-report-basic.t	(original)
+++ Test-Chimps/trunk/t/01-report-basic.t	Fri Jun 23 17:33:29 2006
@@ -3,7 +3,7 @@
 use Test::More tests => 5;
 
 BEGIN {
-  use_ok( 'Test::Smoke::Report' );
+  use_ok( 'Test::Chimps::Report' );
 }
 
 use Test::TAP::Model::Visual;
@@ -11,9 +11,9 @@
 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::Smoke::Report->new(model => $m, report_text => "foo");
+my $r = Test::Chimps::Report->new(model => $m, report_text => "foo");
 ok($r, "the report object is defined");
-isa_ok($r, 'Test::Smoke::Report', "and it's of the correct type");
+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");

Modified: Test-Chimps/trunk/t/05-client-basic.t
==============================================================================
--- Test-Chimps/trunk/t/05-client-basic.t	(original)
+++ Test-Chimps/trunk/t/05-client-basic.t	Fri Jun 23 17:33:29 2006
@@ -2,11 +2,11 @@
 
 use Test::More tests => 6;
 
-use Test::Smoke::Report;
+use Test::Chimps::Report;
 use Test::TAP::Model::Visual;
 
 BEGIN {
-  use_ok( 'Test::Smoke::Report::Client' );
+  use_ok( 'Test::Chimps::Client' );
 }
 
 my $m = Test::TAP::Model::Visual->new_with_tests('t/bogus-tests/00-basic.t');
@@ -15,11 +15,11 @@
 my $r = Test::Smoke::Report->new(model => $m, report_text => "foo");
 
 my $reports = [$r];
-my $c = Test::Smoke::Report::Client->new(reports => $reports,
+my $c = Test::Chimps::Client->new(reports => $reports,
                                          server => 'bogus',
                                          compress => 1);
 ok($c, "the client object is defined");
-isa_ok($c, 'Test::Smoke::Report::Client', "and it's of the correct type");
+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");

Modified: Test-Chimps/trunk/t/10-server-base.t
==============================================================================
--- Test-Chimps/trunk/t/10-server-base.t	(original)
+++ Test-Chimps/trunk/t/10-server-base.t	Fri Jun 23 17:33:29 2006
@@ -3,10 +3,10 @@
 use Test::More tests => 3;
 
 BEGIN {
-  use_ok('Test::Smoke::Report::Server');
+  use_ok('Test::Chimps::Server');
 }
 
-my $s = Test::Smoke::Report::Server->new(base_dir => '/var/www');
+my $s = Test::Chimps::Server->new(base_dir => '/var/www');
 
 ok($s, "the server object is defined");
-isa_ok($s, 'Test::Smoke::Report::Server', "and it's of the correct type");
+isa_ok($s, 'Test::Chimps::Server', "and it's of the correct type");

Modified: Test-Chimps/trunk/t/boilerplate.t
==============================================================================
--- Test-Chimps/trunk/t/boilerplate.t	(original)
+++ Test-Chimps/trunk/t/boilerplate.t	Fri Jun 23 17:33:29 2006
@@ -2,7 +2,7 @@
 
 use strict;
 use warnings;
-use Test::More tests => 3;
+use Test::More tests => 5;
 
 sub not_in_file_ok {
     my ($filename, %regex) = @_;
@@ -45,4 +45,6 @@
     );
 }
 
-module_boilerplate_ok('lib/Test/Smoke/Report.pm');
+module_boilerplate_ok('lib/Test/Chimps/Report.pm');
+module_boilerplate_ok('lib/Test/Chimps/Client.pm');
+module_boilerplate_ok('lib/Test/Chimps/Server.pm');


More information about the Rt-commit mailing list