Initial Commit

database/perl/lib/Test2/API/Stack.pm

@@ -0,0 +1,226 @@
+package Test2::API::Stack;
+use strict;
+use warnings;
+
+our $VERSION = '1.302183';
+
+
+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 2020 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