[Rt-commit] r5479 - in Test-Chimps: branches/categories-rework/bin branches/categories-rework/examples branches/categories-rework/lib/Test/Chimps branches/categories-rework/lib/Test/Chimps/Client branches/categories-rework/lib/Test/Chimps/Server branches/categories-rework/t

zev at bestpractical.com zev at bestpractical.com
Tue Jun 27 19:29:54 EDT 2006


Author: zev
Date: Tue Jun 27 19:29:50 2006
New Revision: 5479

Added:
   Test-Chimps/branches/categories-rework/lib/Test/Chimps/Server/
   Test-Chimps/branches/categories-rework/lib/Test/Chimps/Server/Lister.pm
   Test-Chimps/branches/categories-rework/t/20-lister-basic.t
Modified:
   Test-Chimps/   (props changed)
   Test-Chimps/branches/categories-rework/bin/report_server.pl
   Test-Chimps/branches/categories-rework/examples/list.tmpl
   Test-Chimps/branches/categories-rework/lib/Test/Chimps/Client.pm
   Test-Chimps/branches/categories-rework/lib/Test/Chimps/Client/Poller.pm
   Test-Chimps/branches/categories-rework/lib/Test/Chimps/Report.pm
   Test-Chimps/branches/categories-rework/lib/Test/Chimps/Server.pm

Log:
 r9752 at galvatron:  zev | 2006-06-27 00:18:57 -0400
 moved listing code into Lister


Modified: Test-Chimps/branches/categories-rework/bin/report_server.pl
==============================================================================
--- Test-Chimps/branches/categories-rework/bin/report_server.pl	(original)
+++ Test-Chimps/branches/categories-rework/bin/report_server.pl	Tue Jun 27 19:29:50 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/branches/categories-rework/examples/list.tmpl
==============================================================================
--- Test-Chimps/branches/categories-rework/examples/list.tmpl	(original)
+++ Test-Chimps/branches/categories-rework/examples/list.tmpl	Tue Jun 27 19:29:50 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/branches/categories-rework/lib/Test/Chimps/Client.pm
==============================================================================
--- Test-Chimps/branches/categories-rework/lib/Test/Chimps/Client.pm	(original)
+++ Test-Chimps/branches/categories-rework/lib/Test/Chimps/Client.pm	Tue Jun 27 19:29:50 2006
@@ -90,12 +90,12 @@
   my $self = shift;
   validate_with(
     params => \@_,
-    called => 'The Test::Chimps::Client constructor'
+    called => 'The Test::Chimps::Client constructor',
     spec   => {
       reports  => { type => ARRAYREF },
       server   => 1,
       compress => 0
-    },
+    }
   );
   
   my %args = @_;

Modified: Test-Chimps/branches/categories-rework/lib/Test/Chimps/Client/Poller.pm
==============================================================================
--- Test-Chimps/branches/categories-rework/lib/Test/Chimps/Client/Poller.pm	(original)
+++ Test-Chimps/branches/categories-rework/lib/Test/Chimps/Client/Poller.pm	Tue Jun 27 19:29:50 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/branches/categories-rework/lib/Test/Chimps/Report.pm
==============================================================================
--- Test-Chimps/branches/categories-rework/lib/Test/Chimps/Report.pm	(original)
+++ Test-Chimps/branches/categories-rework/lib/Test/Chimps/Report.pm	Tue Jun 27 19:29:50 2006
@@ -85,7 +85,7 @@
   my $self = shift;
   validate_with(
     params => \@_,
-    called => 'The Test::Chimps::Report constructor'
+    called => 'The Test::Chimps::Report constructor',
     spec   => {
       model            => { isa => 'Test::TAP::Model' },
       report_text      => 0,
@@ -93,7 +93,7 @@
         optional => 1,
         type     => HASHREF
       }
-    },
+    }
   );
 
   my %args = @_;

Modified: Test-Chimps/branches/categories-rework/lib/Test/Chimps/Server.pm
==============================================================================
--- Test-Chimps/branches/categories-rework/lib/Test/Chimps/Server.pm	(original)
+++ Test-Chimps/branches/categories-rework/lib/Test/Chimps/Server.pm	Tue Jun 27 19:29:50 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 {
@@ -150,6 +157,11 @@
         optional => 1,
         default  => 'list.tmpl'
       },
+      lister => {
+        type     => SCALAR,
+        isa      => 'Test::Chimps::Server::Lister',
+        optional => 1
+      },
       max_rate => {
         type      => SCALAR,
         default   => 1 / 30,
@@ -166,7 +178,7 @@
           "greater than or equal to 0" => sub { $_[0] >= 0 }
         }
       },
-      max_smokes_per_subcategory => {
+      max_reports_per_subcategory => {
         type      => SCALAR,
         default   => 5,
         optional  => 1,
@@ -221,7 +233,6 @@
   $self->_validate_params($cgi);  
   $self->_variables_validation_spec($cgi);
   $self->_add_report($cgi);
-  $self->_clean_old_reports($cgi);
 
   print "ok";
 }
@@ -326,10 +337,6 @@
   }
 }
 
-sub _clean_old_reports {
-  # XXX: stub
-}
-
 sub _process_detail {
   my $self = shift;
   my $cgi = shift;
@@ -362,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/branches/categories-rework/lib/Test/Chimps/Server/Lister.pm
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/lib/Test/Chimps/Server/Lister.pm	Tue Jun 27 19:29:50 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/branches/categories-rework/t/20-lister-basic.t
==============================================================================
--- (empty file)
+++ Test-Chimps/branches/categories-rework/t/20-lister-basic.t	Tue Jun 27 19:29:50 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