Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Move event storage out of TB2::History and into a new TB2::History::E…

…ventStorage object.

Then we can add an EventStorage that throws out events.

This was the last use of TB2::Stack and TB2::StackBuilder, so they're removed.

For #198
  • Loading branch information...
commit 9626992f016ceee9d76d8c87d10fabee6b135e48 1 parent 581ee89
@schwern schwern authored
View
55 lib/TB2/History.pm
@@ -3,7 +3,6 @@ package TB2::History;
use Carp;
use TB2::Mouse;
use TB2::Types;
-use TB2::StackBuilder;
use TB2::threads::shared;
with 'TB2::EventHandler',
@@ -86,20 +85,56 @@ Unless otherwise stated, these are all accessor methods of the form:
=head3 events
-A TB2::Stack of events, that include Result objects.
+ my $events = $history->events;
+
+An array ref of all events seen.
+
+=cut
+
+has event_storage =>
+ is => 'ro',
+ isa => 'TB2::History::EventStorage',
+ default => sub {
+ $_[0]->load("TB2::History::EventStorage");
+ return TB2::History::EventStorage->new;
+ };
+
+sub events {
+ my $self = shift;
+ return $self->event_storage->events;
+}
+
+sub results {
+ my $self = shift;
+ return $self->event_storage->results;
+}
+
=head3 event_count
-Get the count of events that are on the stack.
+ my $count = $history->event_count;
+
+Get the count of events that have been seen.
=cut
-buildstack events => 'Any';
+sub event_count {
+ my $self = shift;
+ my $events = $self->events;
+ return scalar @$events;
+}
+
+sub result_count {
+ my $self = shift;
+ my $results = $self->results;
+ return scalar @$results;
+}
+
sub handle_event {
my $self = shift;
my $event = shift;
- $self->events_push($event);
+ $self->event_storage->events_push($event);
return;
}
@@ -182,35 +217,29 @@ sub handle_set_plan {
return;
}
-sub event_count { shift->events_count }
-sub has_events { shift->events_count > 0 }
+sub has_events { shift->event_count > 0 }
=head2 Results
=head3 results
-A TB2::Stack of Result objects.
-
# The result of test #4.
my $result = $history->results->[3];
=cut
-buildstack results => 'TB2::Result::Base';
sub handle_result {
my $self = shift;
my $result = shift;
$self->counter( $self->counter + 1 );
- $self->results_push($result);
- $self->events_push($result);
+ $self->event_storage->events_push($result);
$self->_update_statistics($result);
return;
}
-sub result_count { shift->results_count }
=head2 result_count
View
89 lib/TB2/History/EventStorage.pm
@@ -0,0 +1,89 @@
+package TB2::History::EventStorage;
+
+use TB2::Mouse;
+
+=head1 NAME
+
+TB2::History::EventStorage - Store all events
+
+=head1 SYNOPSIS
+
+ my $storage = TB2::History::EventStorage->new;
+
+ $storage->event_push($event);
+
+ my $events = $storage->events;
+ my $results = $storage->results;
+
+=head1 DESCRIPTION
+
+This object stores L<TB2::Event>s.
+
+=head2 Constructors
+
+=head3 new
+
+ my $storage = TB2::History::EventStorage->new;
+
+Create a new storage object.
+
+=head2 Methods
+
+=head3 events
+
+ my $events = $storage->events;
+
+Returns all L<TB2::Event>s pushed in so far.
+
+Do I<NOT> alter this array directly. Use L<events_push>.
+
+=head3 results
+
+ my $results = $storage->results;
+
+Returns just the L<TB2::Result>s pushed in so far.
+
+Do I<NOT> alter this array directly. Use L<events_push>.
+
+=cut
+
+has events =>
+ is => 'ro',
+ isa => 'ArrayRef[TB2::Event]',
+ default => sub { [] }
+;
+
+has results =>
+ is => 'ro',
+ isa => 'ArrayRef[TB2::Result]',
+ default => sub { [] }
+;
+
+
+=head3 events_push
+
+ $storage->events_push(@events);
+
+Add any number of @events to C<< $storage->events >>.
+
+=cut
+
+sub events_push {
+ my $self = shift;
+
+ push @{$self->events}, @_;
+ push @{$self->results}, grep $_->isa("TB2::Result::Base"), @_;
+
+ return;
+}
+
+
+=head1 SEE ALSO
+
+L<TB2::History::NoEventStorage> is like EventStorage but it silently
+throws away all events. Saves space.
+
+=cut
+
+
+1;
View
156 lib/TB2/Stack.pm
@@ -1,156 +0,0 @@
-package TB2::Stack;
-
-use 5.008001;
-use TB2::Mouse;
-use TB2::Types;
-
-our $VERSION = '1.005000_005';
-$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
-
-use Carp qw(confess);
-
-
-=head1 NAME
-
-TB2::Stack - A stack object to be used when you need a stack of things.
-
-=head1 SYNOPSIS
-
- # TODO
-
- use TB2::Stack;
- my $stack = TB2::Stack->new;
-
-
-=head1 DESCRIPTION
-
-A generic stack object that centralizes the idea of a stack.
-
-=head1 Methods
-
-
-=head2 type
-
-This is a read only attribute that is to be specified at creation if you
-need to have a stack that only contains a specific type of items.
-
-Because this is a stack the value supplied for type is expected to be the
-subtype for ArrayRef. So, for example, if type => 'Str' then items will
-be of type ArrayRef[Str], if type => undef then items will just remain
-of type ArrayRef. Due to the way that the type system works you can only
-specify the inital value of the item, no complex types can be specified.
-
-Default: undef implying that any item can be contained in the stack.
-
-=cut
-
-has type =>
- is => 'ro',
- isa => 'Maybe[Str]',
- default => undef,
-;
-
-# if type is specified re-write the attribute with one of the right type.
-# [NOTE] idealy this should only overwrite the type, of the existing attr, but I
-# was not able to alter $self->meta->get_attribute('items')->type_constraint
-# and have the changes stick. I'm sure that it's possible but I cant' get it to work.
-sub BUILD {
- my $self = CORE::shift;
- if ( defined $self->type ) {
- my $type = sprintf q{ArrayRef[%s]}, $self->type;
- my $value = $self->items ; # save off the value to plug it in later
-
- delete $self->meta->{attributes}->{items}; #remove the old items attribute to reduce confusion
-
- my $items = $self->meta->add_attribute( 'items' => is => 'rw',
- isa => $type,
- );
- $items->set_value($self, $value ) if defined $value;
- }
-}
-
-=head2 items
-
- my $items = $stack->items;
-
-Returns an array ref of the TB2::AssertRecord objects on
-the stack.
-
-=cut
-
-has items =>
- is => 'rw',
- isa => 'ArrayRef',
- default => sub { [] }
-;
-
-=head2 count
-
-Returns the count of the items in the stack.
-
-=cut
-
-sub count {
- scalar( @{ CORE::shift->items } );
-}
-
-=head2 pop
-
-Remove the last element from the items stack and return it.
-
-=cut
-
-sub pop {
- pop @{ CORE::shift->items };
-}
-
-=head2 shift
-
-Remove the first element of the items stack, and return it.
-
-=cut
-
-sub shift {
- CORE::shift @{ CORE::shift->items };
-}
-
-=head2 splice
-
-!!!! CURRENTLY NOT IMPLIMENTED AS THERE COULD BE ISSUES WITH THREADS !!!!
-
-Add or remove elements anywhere in an array
-
-=cut
-
-sub splice { }
-
-=head2 unshift
-
-Prepend item(s) to the beginning of the items stack.
-
-=cut
-
-sub unshift {
- my $self = CORE::shift;
- # can not use 'unshift' like pop/shift as you need to trip the type check
- $self->items([ @_, @{ $self->items } ]);
-}
-
-=head2 push
-
-Append one or more elements to the items stack.
-
-=cut
-
-sub push {
- my $self = CORE::shift;
- # can not use 'push' like pop/shift as you need to trip the type check
- $self->items([ @{ $self->items }, @_ ]);
-}
-
-
-#TODO: would a map & grep method be sane?
-
-no TB2::Mouse;
-1;
View
79 lib/TB2/StackBuilder.pm
@@ -1,79 +0,0 @@
-package TB2::StackBuilder;
-
-use 5.008001;
-use TB2::Mouse;
-use TB2::Mouse::Exporter;
-use TB2::Types;
-
-our $VERSION = '1.005000_005';
-$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
-
-use Carp qw(confess);
-
-
-=head1 NAME
-
-TB2::StackBuilder - A stack builder
-
-=head1 SYNOPSIS
-
- # TODO
-
- use TB2::StackBuilder;
- buildstack items => 'Int';
-
- # is the same as having said:
-
- has items => (
- is => 'rw',
- isa => 'ArrayRef[Int]',
- default => sub{[]},
- );
- sub items_push { ... }
- sub items_pop { ... }
- sub items_count{ ... }
-
-=head1 DESCRIPTION
-
-Exports a keyword buildstack to build up an Attribute array and methods consistanly.
-
-=head1 EXPORTED FUNCTIONS
-
-=head2 buildstack
-
- buildstack $name; # stack is just an ArrayRef
- buildstack $name => $subtype; # ArrayRef[$subtype]
-
-=cut
-
-TB2::Mouse::Exporter->setup_import_methods(
- as_is => [ 'buildstack' ],
-);
-
-sub buildstack ($;$) {
- my $meta = caller->meta;
- my ( $name, $subtype ) = @_;
- $meta->add_attribute(
- $name => is => 'rw',
- isa => (defined $subtype) ? qq{ArrayRef[$subtype]} : q{ArrayRef} ,
- default => sub{[]},
- );
-
- $meta->add_method(
- $name.'_push' => sub{ push @{ shift->$name }, @_; }
- ) unless $meta->has_method($name.'_push');
-
- $meta->add_method(
- $name.'_pop' => sub{ pop @{ shift->$name } }
- ) unless $meta->has_method($name.'_pop');
-
- $meta->add_method(
- $name.'_count'=> sub{ scalar( @{ shift->$name } ) }
- ) unless $meta->has_method($name.'_count');
-
-}
-
-
-no TB2::Mouse;
-1;
View
35 t/Builder2/Stack.t
@@ -1,35 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-BEGIN { require 't/test.pl' }
-
-use_ok( 'TB2::Stack' );
-
-# bare type
-{
- ok my $stack = TB2::Stack->new , q{fresh stack} ;
- is_deeply $stack->items, [], q{empty stack};
- ok $stack->push(1..3), q{push};
- is_deeply $stack->items, [1..3], q{stack};
- ok $stack->unshift('nil'), q{unshift};
- is_deeply $stack->items, ['nil',1..3], q{stack};
- is $stack->pop, 3, q{pop};
- is $stack->shift, 'nil', q{shift};
- is_deeply $stack->items, [1,2], q{stack};
- is $stack->count, 2, q{count};
-}
-
-# simple type
-{
- ok my $stack = TB2::Stack->new(type => 'Int') , q{fresh stack} ;
- ok $stack->push(1), q{push int};
- eval { $stack->push(undef) };
- like $@, qr{Attribute \(items\) does not pass the type constraint}, q{type check};
- is_deeply $stack->items, [1];
-
-
-}
-
-done_testing;
View
64 t/Builder2/StackBuilder.t
@@ -1,64 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-BEGIN { require 't/test.pl' }
-
-use_ok( 'TB2::StackBuilder' );
-
-BEGIN {
- package My::One;
- use TB2::Mouse;
- use TB2::StackBuilder;
-}
-
-{
- can_ok 'My::One', qw{buildstack};
-}
-
-BEGIN {
- package My::Two;
- use TB2::Mouse;
- use TB2::StackBuilder;
- buildstack 'items';
-}
-
-{
- can_ok 'My::Two', qw{ buildstack
- items
- items_push
- items_pop
- items_count
- };
- my $two = My::Two->new;
- is_deeply $two->items, [];
- ok $two->items_push(1..3);
- is $two->items_count, 3;
- is_deeply $two->items, [1..3];
- ok $two->items_push('end');
- is $two->items_pop, 'end';
-}
-
-BEGIN {
- package My::Three;
- use TB2::Mouse;
- use TB2::StackBuilder;
- sub nums_count {'buildin'};
- buildstack nums => 'Int';
-}
-
-{
- my $three = My::Three->new;
- is $three->nums_count, 'buildin', q{buildstack does not squash existing methods};
-
- TODO: {
- our $TODO;
- local $TODO = "This would be nice, but the implementation was very inefficient and messed with threads";
-
- eval { $three->nums_push('this is a string') };
- like $@, qr{^Attribute \(nums\) does not pass the type constraint because}, q{type enforced};
- }
-}
-
-done_testing;
View
28 t/History/EventStorage.t
@@ -0,0 +1,28 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+BEGIN { require "t/test.pl" }
+
+use TB2::Events;
+
+my $CLASS = 'TB2::History::EventStorage';
+require_ok $CLASS;
+
+note "Event and result storage"; {
+ my $storage = $CLASS->new;
+
+ is_deeply $storage->events, [], "empty events";
+ is_deeply $storage->results, [], "empty results";
+
+ my @events = map { TB2::Event::Comment->new( comment => "No $_" ) } 1..4;
+ my @results = map { TB2::Result->new_result } 1..2;
+
+ $storage->events_push( @events, @results );
+
+ is_deeply $storage->events, [@events, @results], "events_push to events";
+ is_deeply $storage->results, [@results], "events_push split out results";
+}
+
+done_testing;
Please sign in to comment.
Something went wrong with that request. Please try again.