Current File : //usr/local/share/perl5/Test2/API/Stack.pm
package Test2::API::Stack;
use strict;
use warnings;
our $VERSION = '1.302177';
use Test2::Hub();
use Carp qw/confess/;
sub new {
my $class = shift;
return bless [], $class;
}
sub new_hub {
my $self = shift;
my %params = @_;
my $class = delete $params{class} || 'Test2::Hub';
my $hub = $class->new(%params);
if (@$self) {
$hub->inherit($self->[-1], %params);
}
else {
require Test2::API;
$hub->format(Test2::API::test2_formatter()->new_root)
unless $hub->format || exists($params{formatter});
my $ipc = Test2::API::test2_ipc();
if ($ipc && !$hub->ipc && !exists($params{ipc})) {
$hub->set_ipc($ipc);
$ipc->add_hub($hub->hid);
}
}
push @$self => $hub;
$hub;
}
sub top {
my $self = shift;
return $self->new_hub unless @$self;
return $self->[-1];
}
sub peek {
my $self = shift;
return @$self ? $self->[-1] : undef;
}
sub cull {
my $self = shift;
$_->cull for reverse @$self;
}
sub all {
my $self = shift;
return @$self;
}
sub root {
my $self = shift;
return unless @$self;
return $self->[0];
}
sub clear {
my $self = shift;
@$self = ();
}
# Do these last without keywords in order to prevent them from getting used
# when we want the real push/pop.
{
no warnings 'once';
*push = sub {
my $self = shift;
my ($hub) = @_;
$hub->inherit($self->[-1]) if @$self;
push @$self => $hub;
};
*pop = sub {
my $self = shift;
my ($hub) = @_;
confess "No hubs on the stack"
unless @$self;
confess "You cannot pop the root hub"
if 1 == @$self;
confess "Hub stack mismatch, attempted to pop incorrect hub"
unless $self->[-1] == $hub;
pop @$self;
};
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::API::Stack - Object to manage a stack of L<Test2::Hub>
instances.
=head1 ***INTERNALS NOTE***
B<The internals of this package are subject to change at any time!> The public
methods provided will not change in backwards incompatible ways, but the
underlying implementation details might. B<Do not break encapsulation here!>
=head1 DESCRIPTION
This module is used to represent and manage a stack of L<Test2::Hub>
objects. Hubs are usually in a stack so that you can push a new hub into place
that can intercept and handle events differently than the primary hub.
=head1 SYNOPSIS
my $stack = Test2::API::Stack->new;
my $hub = $stack->top;
=head1 METHODS
=over 4
=item $stack = Test2::API::Stack->new()
This will create a new empty stack instance. All arguments are ignored.
=item $hub = $stack->new_hub()
=item $hub = $stack->new_hub(%params)
=item $hub = $stack->new_hub(%params, class => $class)
This will generate a new hub and push it to the top of the stack. Optionally
you can provide arguments that will be passed into the constructor for the
L<Test2::Hub> object.
If you specify the C<< 'class' => $class >> argument, the new hub will be an
instance of the specified class.
Unless your parameters specify C<'formatter'> or C<'ipc'> arguments, the
formatter and IPC instance will be inherited from the current top hub. You can
set the parameters to C<undef> to avoid having a formatter or IPC instance.
If there is no top hub, and you do not ask to leave IPC and formatter undef,
then a new formatter will be created, and the IPC instance from
L<Test2::API> will be used.
=item $hub = $stack->top()
This will return the top hub from the stack. If there is no top hub yet this
will create it.
=item $hub = $stack->peek()
This will return the top hub from the stack. If there is no top hub yet this
will return undef.
=item $stack->cull
This will call C<< $hub->cull >> on all hubs in the stack.
=item @hubs = $stack->all
This will return all the hubs in the stack as a list.
=item $stack->clear
This will completely remove all hubs from the stack. Normally you do not want
to do this, but there are a few valid reasons for it.
=item $stack->push($hub)
This will push the new hub onto the stack.
=item $stack->pop($hub)
This will pop a hub from the stack, if the hub at the top of the stack does not
match the hub you expect (passed in as an argument) it will throw an exception.
=back
=head1 SOURCE
The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2019 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut
Mini Shell