[Rt-commit] r5507 - in Test-Chimps: trunk trunk/bin trunk/examples
trunk/lib/Test/Chimps trunk/lib/Test/Chimps/Client
trunk/lib/Test/Chimps/Server trunk/t
zev at bestpractical.com
zev at bestpractical.com
Mon Jul 3 18:12:31 EDT 2006
Author: zev
Date: Mon Jul 3 18:12:30 2006
New Revision: 5507
Added:
Test-Chimps/trunk/lib/Test/Chimps/Server/
Test-Chimps/trunk/lib/Test/Chimps/Server/Lister.pm
Test-Chimps/trunk/t/20-lister-basic.t
Modified:
Test-Chimps/ (props changed)
Test-Chimps/trunk/ (props changed)
Test-Chimps/trunk/bin/report_server.pl
Test-Chimps/trunk/examples/list.tmpl
Test-Chimps/trunk/lib/Test/Chimps/Client.pm
Test-Chimps/trunk/lib/Test/Chimps/Client/Poller.pm
Test-Chimps/trunk/lib/Test/Chimps/Report.pm
Test-Chimps/trunk/lib/Test/Chimps/Server.pm
Log:
r9772 at galvatron: zev | 2006-07-02 20:27:25 -0400
merging categories reworking into trunk
Modified: Test-Chimps/trunk/bin/report_server.pl
==============================================================================
--- Test-Chimps/trunk/bin/report_server.pl (original)
+++ Test-Chimps/trunk/bin/report_server.pl Mon Jul 3 18:12:30 2006
@@ -1,15 +1,20 @@
#!/usr/bin/env perl
+use lib '/home/zev/bps/Test-Chimps/branches/categories-rework/lib';
+
use Test::Chimps::Server;
my $server = Test::Chimps::Server->new(base_dir => '/var/www/bps-smokes',
+ list_template => 'list2.tmpl',
variables_validation_spec =>
- { category => 1,
- subcategory => 1,
- project => 1,
+ { project => 1,
revision => 1,
author => 1,
timestamp => 1,
- duration => 1 });
+ duration => 1,
+ osname => 1,
+ osver => 1,
+ archname => 1
+ });
$server->handle_request;
Modified: Test-Chimps/trunk/examples/list.tmpl
==============================================================================
--- Test-Chimps/trunk/examples/list.tmpl (original)
+++ Test-Chimps/trunk/examples/list.tmpl Mon Jul 3 18:12:30 2006
@@ -72,12 +72,11 @@
</p>
<table>
-% foreach my $category (sort keys %categories) {
+% foreach my $category (sort keys %$categories) {
<tr><th colspan="11" class="category"><% $category %></th></tr>
-% foreach my $subcategory (sort keys %{$categories{$category}}) {
+% 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}}) {
+% foreach my $report (@{$categories->{$category}->{$subcategory}}) {
% my $id = $report->{id};
% my $data = $report->report_variables;
% my $model = Test::TAP::Model::Visual->new_with_struct($report->model_structure);
@@ -119,29 +118,6 @@
</html>
<%args>
-$report_dir
- at reports
+$categories
</%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>
Modified: Test-Chimps/trunk/lib/Test/Chimps/Client.pm
==============================================================================
--- Test-Chimps/trunk/lib/Test/Chimps/Client.pm (original)
+++ Test-Chimps/trunk/lib/Test/Chimps/Client.pm Mon Jul 3 18:12:30 2006
@@ -88,13 +88,15 @@
sub _init {
my $self = shift;
- validate_with(params => \@_,
- spec =>
- { reports =>
- { type => ARRAYREF },
- server => 1,
- compress => 0},
- called => 'The Test::Chimps::Client constructor');
+ validate_with(
+ params => \@_,
+ called => 'The Test::Chimps::Client constructor',
+ spec => {
+ reports => { type => ARRAYREF },
+ server => 1,
+ compress => 0
+ }
+ );
my %args = @_;
$self->{reports} = $args{reports};
Modified: Test-Chimps/trunk/lib/Test/Chimps/Client/Poller.pm
==============================================================================
--- Test-Chimps/trunk/lib/Test/Chimps/Client/Poller.pm (original)
+++ Test-Chimps/trunk/lib/Test/Chimps/Client/Poller.pm Mon Jul 3 18:12:30 2006
@@ -171,13 +171,15 @@
my $report = Test::Chimps::Report->new(model => $model,
report_variables =>
- { category => $project,
- subcategory => 'repository snapshot / ' . $Config{osname},
- project => scalar fileparse($config->{$project}->{svn_uri}),
+ { project => $project,
revision => $revision,
author => $author,
timestamp => scalar gmtime,
- duration => $duration});
+ duration => $duration,
+ osname => $Config{osname},
+ osver => $Config{osver},
+ archname => $Config{archname}
+ });
my $client = Test::Chimps::Client->new(reports => [$report],
server => $self->server);
Modified: Test-Chimps/trunk/lib/Test/Chimps/Report.pm
==============================================================================
--- Test-Chimps/trunk/lib/Test/Chimps/Report.pm (original)
+++ Test-Chimps/trunk/lib/Test/Chimps/Report.pm Mon Jul 3 18:12:30 2006
@@ -83,16 +83,18 @@
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');
+ validate_with(
+ params => \@_,
+ called => 'The Test::Chimps::Report constructor',
+ spec => {
+ model => { isa => 'Test::TAP::Model' },
+ report_text => 0,
+ report_variables => {
+ optional => 1,
+ type => HASHREF
+ }
+ }
+ );
my %args = @_;
Modified: Test-Chimps/trunk/lib/Test/Chimps/Server.pm
==============================================================================
--- Test-Chimps/trunk/lib/Test/Chimps/Server.pm (original)
+++ Test-Chimps/trunk/lib/Test/Chimps/Server.pm Mon Jul 3 18:12:30 2006
@@ -4,6 +4,7 @@
use strict;
use Test::Chimps::Report;
+use Test::Chimps::Server::Lister;
use Algorithm::TokenBucket;
use CGI::Carp qw<fatalsToBrowser>;
@@ -12,7 +13,6 @@
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;
@@ -69,6 +69,12 @@
Template filename under base_dir/template_dir to use for listing
smoke reports. Defaults to 'list.tmpl'.
+=item * lister
+
+An instance of L<Test::Chimps::Server::Lister> to use to list smoke
+reports. You do not have to use this option unless you are
+subclassing C<Lister>.
+
=item * max_rate
Maximum upload rate allowed (see L<Algorithm::Bucket>). Defaults
@@ -79,7 +85,7 @@
Maximum size of HTTP POST that will be accepted. Defaults to 3
MiB.
-=item * max_smokes_per_subcategory
+=item * max_reports_per_subcategory
Maximum number of smokes allowed per category. Defaults to 5.
@@ -107,8 +113,9 @@
__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/
+ max_reports_per_subcategory report_dir
+ template_dir list_template lister
+ variables_validation_spec/
);
sub new {
@@ -120,61 +127,77 @@
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 }
- });
+ my %args = validate_with(
+ params => \@_,
+ called => 'The Test::Chimps::Server constructor',
+ spec => {
+ base_dir => {
+ type => SCALAR,
+ optional => 0
+ },
+ bucket_file => {
+ type => SCALAR,
+ default => 'bucket.dat',
+ optional => 1
+ },
+ burst_rate => {
+ type => SCALAR,
+ optional => 1,
+ default => 5,
+ callbacks => {
+ "greater than or equal to 0" => sub { $_[0] >= 0 }
+ }
+ },
+ variables_validation_spec => {
+ type => HASHREF,
+ optional => 1
+ },
+ list_template => {
+ type => SCALAR,
+ optional => 1,
+ default => 'list.tmpl'
+ },
+ lister => {
+ type => SCALAR,
+ isa => 'Test::Chimps::Server::Lister',
+ optional => 1
+ },
+ max_rate => {
+ type => SCALAR,
+ default => 1 / 30,
+ optional => 1,
+ callbacks => {
+ "greater than or equal to 0" => sub { $_[0] >= 0 }
+ }
+ },
+ max_size => {
+ type => SCALAR,
+ default => 2**20 * 3.0,
+ optional => 1,
+ callbacks => {
+ "greater than or equal to 0" => sub { $_[0] >= 0 }
+ }
+ },
+ max_reports_per_subcategory => {
+ type => SCALAR,
+ default => 5,
+ optional => 1,
+ callbacks => {
+ "greater than or equal to 0" => sub { $_[0] >= 0 }
+ }
+ },
+ report_dir => {
+ type => SCALAR,
+ default => 'reports',
+ optional => 1
+ },
+ template_dir => {
+ type => SCALAR,
+ default => 'templates',
+ optional => 1
+ }
+ }
+ );
foreach my $key (keys %args) {
$self->{$key} = $args{$key};
@@ -210,7 +233,6 @@
$self->_validate_params($cgi);
$self->_variables_validation_spec($cgi);
$self->_add_report($cgi);
- $self->_clean_old_reports($cgi);
print "ok";
}
@@ -315,10 +337,6 @@
}
}
-sub _clean_old_reports {
- # XXX: stub
-}
-
sub _process_detail {
my $self = shift;
my $cgi = shift;
@@ -351,20 +369,27 @@
my @reports = map { LoadFile($_) } @files;
+ # XXX FIXME we shouldn't just be adding this stuff here
for (my $i = 0; $i < scalar @reports ; $i++) {
my ($filename, $directories, $suffix) = fileparse($files[$i], '.yml');
$reports[$i]->{url} = $cgi->url . "?id=$filename";
$reports[$i]->{id} = $filename;
}
+
+ my $lister;
+ if (defined $self->lister) {
+ $lister = $self->lister;
+ } else {
+ $lister = Test::Chimps::Server::Lister->new(
+ list_template => $self->list_template,
+ max_reports_per_subcategory => $self->max_reports_per_subcategory
+ );
+ }
- 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);
-
+ $lister->output_list(File::Spec->catdir($self->{base_dir},
+ $self->{template_dir}),
+ \@reports);
+
}
=head1 AUTHOR
Added: Test-Chimps/trunk/lib/Test/Chimps/Server/Lister.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/trunk/lib/Test/Chimps/Server/Lister.pm Mon Jul 3 18:12:30 2006
@@ -0,0 +1,165 @@
+package Test::Chimps::Server::Lister;
+
+use warnings;
+use strict;
+
+use Params::Validate qw<:all>;
+use Test::Chimps::Report;
+use HTML::Mason;
+use DateTime;
+use Date::Parse;
+
+=head1 NAME
+
+Test::Chimps::Server::Lister - Format the list of smoke reports
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+=head1 SYNOPSIS
+
+This module encapsulates the formatting and output of the smoke
+report list. You should not have to use this module directly
+unless you need to customize listing output. To do so, subclass
+C<Lister> and pass one to your C<Server>.
+
+ package MyLister;
+
+ use base 'Test::Chimps::Server::Lister';
+
+ sub foo { ... }
+
+ package main;
+
+ use Test::Chimps::Server;
+
+ my $lister = MyLister->new();
+
+ my $server = Test::Chimps::Server->new(
+ base_dir => '/var/www/smokes',
+ lister => $lister
+ );
+
+ $server->handle_request;
+
+=head1 METHODS
+
+=cut
+
+use base qw/Class::Accessor/;
+
+__PACKAGE__->mk_ro_accessors(
+ qw/max_reports_per_subcategory list_template/
+);
+
+
+sub new {
+ my $class = shift;
+ my $obj = bless {}, $class;
+ $obj->_init(@_);
+ return $obj;
+}
+
+sub _init {
+ my $self = shift;
+ my %args = validate_with(
+ params => \@_,
+ called => 'The Test::Chimps::Server::Lister constructor',
+ spec => {
+ list_template => {
+ type => SCALAR,
+ optional => 0,
+ },
+ max_reports_per_subcategory => {
+ type => SCALAR,
+ optional => 0
+ }
+ }
+ );
+
+ foreach my $key (keys %args) {
+ $self->{$key} = $args{$key};
+ }
+}
+
+sub output_list {
+ my ($self, $template_dir, $reports) = @_;
+
+ my $interp = HTML::Mason::Interp->new(comp_root => $template_dir);
+
+ my $categories = $self->_build_heirarchy($reports);
+
+ $interp->exec(File::Spec->catfile(File::Spec->rootdir,
+ $self->list_template),
+ categories => $categories);
+}
+
+sub _build_heirarchy {
+ my $self = shift;
+ my $reports = shift;
+
+ my $categories = {};
+ foreach my $report (@$reports) {
+ my $category = $self->_compute_category($report);
+ my $subcategory = $self->_compute_subcategory($report);
+ push @{$categories->{$category}->{$subcategory}}, $report;
+ }
+ $self->_sort_reports($categories);
+ $self->_prune_reports($categories);
+ return $categories;
+}
+
+sub _compute_category {
+ my $self = shift;
+ my $report = shift;
+ return $report->report_variables->{project};
+}
+
+sub _compute_subcategory {
+ my $self = shift;
+ my $report = shift;
+ return '';
+}
+
+sub _sort_reports {
+ my $self = shift;
+ my $categories = shift;
+
+ foreach my $category (keys %$categories) {
+ foreach my $subcategory (keys %{$categories->{$category}}) {
+ @{$categories->{$category}->{$subcategory}} =
+ sort _by_revision_then_date @{$categories->{$category}->{$subcategory}};
+ }
+ }
+}
+
+sub _by_revision_then_date {
+ my $res = $b->report_variables->{revision} <=> $a->report_variables->{revision};
+
+ if ($res != 0) {
+ return $res;
+ }
+
+ my ($adate, $bdate) = (DateTime->from_epoch(epoch => str2time($a->report_variables->{timestamp})),
+ DateTime->from_epoch(epoch => str2time($b->report_variables->{timestamp})));
+ return DateTime->compare($bdate, $adate);
+}
+
+sub _prune_reports {
+ my $self = shift;
+ my $categories = shift;
+
+ foreach my $category (keys %$categories) {
+ foreach my $subcategory (keys %{$categories->{$category}}) {
+ @{$categories->{$category}->{$subcategory}} =
+ @{$categories->{$category}->{$subcategory}}[0 .. ($self->max_reports_per_subcategory - 1)];
+ }
+ }
+}
+
+1;
Added: Test-Chimps/trunk/t/20-lister-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/trunk/t/20-lister-basic.t Mon Jul 3 18:12:30 2006
@@ -0,0 +1,13 @@
+#!perl -T
+
+use Test::More tests => 3;
+
+BEGIN {
+ use_ok('Test::Chimps::Server::Lister');
+}
+
+my $s = Test::Chimps::Server::Lister->new(list_template => 'bogus',
+ max_reports_per_subcategory => 10);
+
+ok($s, "the server object is defined");
+isa_ok($s, 'Test::Chimps::Server::Lister', "and it's of the correct type");
More information about the Rt-commit
mailing list