[Rt-commit] r5421 - in Test-Chimps: . trunk trunk/bin
trunk/lib/Test/Smoke/Report trunk/t trunk/t/bogus-tests
zev at bestpractical.com
zev at bestpractical.com
Fri Jun 23 17:32:21 EDT 2006
Author: zev
Date: Fri Jun 23 17:32:20 2006
New Revision: 5421
Added:
Test-Chimps/trunk/lib/Test/Smoke/Report/Server.pm
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/bogus-tests/
Test-Chimps/trunk/t/bogus-tests/00-basic.t
Modified:
Test-Chimps/ (props changed)
Test-Chimps/trunk/Makefile.PL
Test-Chimps/trunk/bin/submit_report.pl
Test-Chimps/trunk/lib/Test/Smoke/Report.pm
Test-Chimps/trunk/lib/Test/Smoke/Report/Client.pm
Log:
r4185 at galvatron (orig r2): zev | 2006-06-20 17:58:20 -0400
r4125 at galvatron: zev | 2006-06-16 22:44:15 -0400
wrote lots of tests, documented, and have most of server submission working
Modified: Test-Chimps/trunk/Makefile.PL
==============================================================================
--- Test-Chimps/trunk/Makefile.PL (original)
+++ Test-Chimps/trunk/Makefile.PL Fri Jun 23 17:32:20 2006
@@ -1,16 +1,23 @@
-use strict;
-use warnings;
-use ExtUtils::MakeMaker;
+use inc::Module::Install;
-WriteMakefile(
- NAME => 'Test::Smoke::Report',
- AUTHOR => 'Zev Benjamin <zev at cpan.org>',
- VERSION_FROM => 'lib/Test/Smoke/Report.pm',
- ABSTRACT_FROM => 'lib/Test/Smoke/Report.pm',
- PL_FILES => {},
- PREREQ_PM => {
- 'Test::More' => 0,
- },
- dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
- clean => { FILES => 'Test-Smoke-Report-*' },
-);
+# Define metadata
+name 'Test-Smoke-Report';
+all_from 'lib/Test/Smoke/Report.pm';
+
+# Specific dependencies
+requires('Algorithm::TokenBucket');
+requires('HTML::Template');
+requires('LWP::UserAgent');
+requires('Module::CoreList');
+requires('Params::Validate');
+requires('Test::TAP::HTMLMatrix');
+requires('Test::TAP::Model::Visual');
+requires('Time::Piece');
+requires('Time::Seconds');
+requires('YAML::Syck');
+
+
+no_index 'directory' => 'demos';
+
+auto_install;
+WriteAll;
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:32:20 2006
@@ -3,7 +3,7 @@
use warnings;
use strict;
-use lib '/home/zev/bps/Test-Smoke-Report/lib';
+use lib '/home/zev/bps/Test-Smoke-Report/trunk/lib';
use Getopt::Long;
use Test::Smoke::Report;
@@ -17,7 +17,7 @@
my $report = Test::Smoke::Report->new(model => $model);
my $client = Test::Smoke::Report::Client->new(reports => [$report],
- server => 'http://galvatron.mit.edu/cgi-bin/smokeserv-server.pl');
+ server => 'http://galvatron.mit.edu/cgi-bin/receive_report.pl');
my ($status, $msg) = $client->send;
Modified: Test-Chimps/trunk/lib/Test/Smoke/Report.pm
==============================================================================
--- Test-Chimps/trunk/lib/Test/Smoke/Report.pm (original)
+++ Test-Chimps/trunk/lib/Test/Smoke/Report.pm Fri Jun 23 17:32:20 2006
@@ -30,12 +30,24 @@
chdir "some/module/directory";
- my $model = Test::TAP::Model::Visual->new_with_tests(glob("t/*.t"));# t/*/t/*.t"));
+ 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 C<model>
+and C<report_text>. C<model> is mandatory and must be an instance
+of C<Test::Tap::Model>. C<report_text> is an optional free-form
+report. If not supplied, it is filled in using
+C<Test::TAP::HTMLMatrix>. Note that if you are using this class in
+conjunction with C<Test::Smoke::Report::Server>, C<report_text>
+should probably be HTML.
+
=cut
sub new {
@@ -63,11 +75,23 @@
}
}
+=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};
@@ -115,6 +139,9 @@
=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.
@@ -124,4 +151,4 @@
=cut
-1; # End of Test::Smoke::Report
+1;
Modified: Test-Chimps/trunk/lib/Test/Smoke/Report/Client.pm
==============================================================================
--- Test-Chimps/trunk/lib/Test/Smoke/Report/Client.pm (original)
+++ Test-Chimps/trunk/lib/Test/Smoke/Report/Client.pm Fri Jun 23 17:32:20 2006
@@ -11,6 +11,70 @@
use constant PROTO_VERSION => 0.1;
+=head1 NAME
+
+Test::Smoke::Report::Client - Send a Test::Smoke::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::Smoke::Report>s to a smoke server.
+
+ use Test::Smoke::Report;
+ use Test::Smoke::Report::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::Smoke::Report->new(model => $model);
+
+ my $client = Test::Smoke::Report::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::Smoke::Report>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;
@@ -36,21 +100,47 @@
$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;
@@ -73,4 +163,59 @@
}
}
+=head1 AUTHOR
+
+Zev Benjamin, C<< <zev at cpan.org> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-test-smoke-report at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Smoke-Report>.
+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::Smoke::Report
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Test-Smoke-Report>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Test-Smoke-Report>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Smoke-Report>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Test-Smoke-Report>
+
+=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/Smoke/Report/Server.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/trunk/lib/Test/Smoke/Report/Server.pm Fri Jun 23 17:32:20 2006
@@ -0,0 +1,270 @@
+package Test::Smoke::Report::Server;
+
+use warnings;
+use strict;
+
+use Algorithm::TokenBucket;
+use CGI::Carp qw<fatalsToBrowser>;
+use CGI;
+use Digest::MD5 qw<md5_hex>;
+use File::Spec;
+use Fcntl qw<:DEFAULT :flock>;
+use HTML::Template;
+use Params::Validate qw<:all>;
+use Storable qw<store_fd fd_retrieve freeze>;
+use Time::Piece;
+use Time::Seconds;
+
+use constant PROTO_VERSION => 0.1;
+
+=head1 NAME
+
+Test::Smoke::Report::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::Smoke::Report::Client.
+
+ use Test::Smoke::Report::Server;
+
+ my $server = Test::Smoke::Report::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 * 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_same_category
+
+Maximum number of smokes allowed per category. Defaults to 5.
+
+=item * report_dir
+
+Directory under basedir where smoke reports will be stored.
+Defaults to 'reports'.
+
+=back
+
+=cut
+
+{
+ no strict 'refs';
+ our @fields = qw/base_dir bucket_file max_rate max_size
+ max_smokes_same_category report_dir/;
+
+ 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(@_,
+ { 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 }} },
+ 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_same_category =>
+ { type => SCALAR,
+ default => 5,
+ optional => 1,
+ callbacks =>
+ { "greater than or equal to 0" =>
+ sub { $_[0] >= 0 }} },
+ report_dir =>
+ { type => SCALAR,
+ default => 'reports',
+ 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);
+ } else {
+ $self->_process_listing();
+ }
+}
+
+sub _process_upload {
+ my $self = shift;
+ my $cgi = shift;
+
+ print $cgi->header("text/plain");
+ $self->_limit_rate($cgi);
+ $self->_validate_params($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 _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},
+ $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
+}
+
+
+
+1;
Added: Test-Chimps/trunk/t/00-dependencies.t
==============================================================================
--- (empty file)
+++ Test-Chimps/trunk/t/00-dependencies.t Fri Jun 23 17:32:20 2006
@@ -0,0 +1,64 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+=head1 DESCRIPTION
+
+Makes sure that all of the modules that are 'use'd are listed in the
+Makefile.PL as dependencies.
+
+=cut
+
+use Test::More qw(no_plan);
+use File::Find;
+use Module::CoreList;
+
+my %used;
+find( \&wanted, qw/ lib bin t /);
+
+sub wanted {
+ return unless -f $_;
+ return if $File::Find::dir =~ m!/.svn($|/)!;
+ return if $File::Find::name =~ /~$/;
+ return if $File::Find::name =~ /\.pod$/;
+ local $/;
+ open(FILE, $_) or return;
+ my $data = <FILE>;
+ close(FILE);
+ $used{$1}++ while $data =~ /^\s*use\s+([\w:]+)/gm;
+ while ($data =~ m|^\s*use base qw.([\w\s:]+)|gm) {
+ $used{$_}++ for split ' ', $1;
+ }
+}
+
+my %required;
+{
+ local $/;
+ ok(open(MAKEFILE,"Makefile.PL"), "Opened Makefile");
+ my $data = <MAKEFILE>;
+ close(FILE);
+ while ($data =~ /^\s*?requires\('([\w:]+)'(?:\s*=>\s*['"]?([\d\.]+)['"]?)?.*?(?:#(.*))?$/gm) {
+ $required{$1} = $2;
+ if (defined $3 and length $3) {
+ $required{$_} = undef for split ' ', $3;
+ }
+ }
+}
+
+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)(::|$)/;
+ ok(exists $required{$_}, "$_ in Makefile.PL");
+ delete $used{$_};
+ delete $required{$_};
+}
+
+for (sort keys %required) {
+ my $first_in = Module::CoreList->first_release($_, $required{$_});
+ fail("Required module $_ is already in core") if defined $first_in and $first_in <= 5.00803;
+}
+
+1;
+
Added: Test-Chimps/trunk/t/01-report-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/trunk/t/01-report-basic.t Fri Jun 23 17:32:20 2006
@@ -0,0 +1,19 @@
+#!perl -T
+
+use Test::More tests => 5;
+
+BEGIN {
+ use_ok( 'Test::Smoke::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::Smoke::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");
+
+is($r->model_structure, $m->structure, "the model_structure accessor works");
+is($r->report_text, "foo", "the report_text accessor works");
Added: Test-Chimps/trunk/t/05-client-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/trunk/t/05-client-basic.t Fri Jun 23 17:32:20 2006
@@ -0,0 +1,26 @@
+#!perl -T
+
+use Test::More tests => 6;
+
+use Test::Smoke::Report;
+use Test::TAP::Model::Visual;
+
+BEGIN {
+ use_ok( 'Test::Smoke::Report::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::Smoke::Report->new(model => $m, report_text => "foo");
+
+my $reports = [$r];
+my $c = Test::Smoke::Report::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");
+
+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/trunk/t/10-server-base.t
==============================================================================
--- (empty file)
+++ Test-Chimps/trunk/t/10-server-base.t Fri Jun 23 17:32:20 2006
@@ -0,0 +1,12 @@
+#!perl -T
+
+use Test::More tests => 3;
+
+BEGIN {
+ use_ok('Test::Smoke::Report::Server');
+}
+
+my $s = Test::Smoke::Report::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");
Added: Test-Chimps/trunk/t/bogus-tests/00-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/trunk/t/bogus-tests/00-basic.t Fri Jun 23 17:32:20 2006
@@ -0,0 +1,9 @@
+#!perl -T
+
+use Test::More tests => 3;
+
+is(1, 1);
+
+ok(1+1 == 2);
+
+isnt(2+2, 5);
More information about the Rt-commit
mailing list