[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