File Coverage

blib/lib/Test2/API/Stack.pm
Criterion Covered Total %
statement 52 52 100.0
branch 16 18 88.8
condition 7 11 63.6
subroutine 14 14 100.0
pod 7 7 100.0
total 96 102 94.1


line stmt bran cond sub pod time code
1             package Test2::API::Stack;
2 54     54   177 use strict;
  54         52  
  54         1187  
3 54     54   151 use warnings;
  54         45  
  54         1548  
4              
5             our $VERSION = '0.000042';
6              
7 54     54   17831 use Test2::Hub();
  54         73  
  54         972  
8              
9 54     54   223 use Carp qw/confess/;
  54         55  
  54         14387  
10              
11             sub new {
12 149     149 1 172 my $class = shift;
13 149         350 return bless [], $class;
14             }
15              
16             sub new_hub {
17 131     131 1 143 my $self = shift;
18 131         194 my %params = @_;
19              
20 131   100     514 my $class = delete $params{class} || 'Test2::Hub';
21              
22 131         654 my $hub = $class->new(%params);
23              
24 131 100       292 if (@$self) {
25 58         265 $hub->inherit($self->[-1], %params);
26             }
27             else {
28 73         336 require Test2::API;
29             $hub->format(Test2::API::test2_formatter()->new)
30 73 50 33     208 unless $hub->format || exists($params{formatter});
31              
32 73         217 my $ipc = Test2::API::test2_ipc();
33 73 50 66     313 if ($ipc && !$hub->ipc && !exists($params{ipc})) {
      66        
34 40         104 $hub->set_ipc($ipc);
35 40         110 $ipc->add_hub($hub->hid);
36             }
37             }
38              
39 131         227 push @$self => $hub;
40              
41 131         377 $hub;
42             }
43              
44             sub top {
45 133     133 1 153 my $self = shift;
46 133 100       378 return $self->new_hub unless @$self;
47 60         148 return $self->[-1];
48             }
49              
50             sub peek {
51 2     2 1 3 my $self = shift;
52 2 100       9 return @$self ? $self->[-1] : undef;
53             }
54              
55             sub cull {
56 1     1 1 10 my $self = shift;
57 1         3 $_->cull for reverse @$self;
58             }
59              
60             sub all {
61 73     73 1 123 my $self = shift;
62 73         224 return @$self;
63             }
64              
65             sub clear {
66 2     2 1 14 my $self = shift;
67 2         4 @$self = ();
68             }
69              
70             # Do these last without keywords in order to prevent them from getting used
71             # when we want the real push/pop.
72              
73             {
74 54     54   243 no warnings 'once';
  54         54  
  54         7190  
75              
76             *push = sub {
77 15     15   21 my $self = shift;
78 15         17 my ($hub) = @_;
79 15 100       57 $hub->inherit($self->[-1]) if @$self;
80 15         25 push @$self => $hub;
81             };
82              
83             *pop = sub {
84 59     59   104 my $self = shift;
85 59         66 my ($hub) = @_;
86 59 100       260 confess "No hubs on the stack"
87             unless @$self;
88 58 100       191 confess "You cannot pop the root hub"
89             if 1 == @$self;
90 57 100       204 confess "Hub stack mismatch, attempted to pop incorrect hub"
91             unless $self->[-1] == $hub;
92 56         112 pop @$self;
93             };
94             }
95              
96             1;
97              
98             __END__