281 lines
5.8 KiB
Perl
281 lines
5.8 KiB
Perl
package Test2::Event::Generic;
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Carp qw/croak/;
|
|
use Scalar::Util qw/reftype/;
|
|
|
|
our $VERSION = '1.302175';
|
|
|
|
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
|
|
use Test2::Util::HashBase;
|
|
|
|
my @FIELDS = qw{
|
|
causes_fail increments_count diagnostics no_display callback terminate
|
|
global sets_plan summary facet_data
|
|
};
|
|
my %DEFAULTS = (
|
|
causes_fail => 0,
|
|
increments_count => 0,
|
|
diagnostics => 0,
|
|
no_display => 0,
|
|
);
|
|
|
|
sub init {
|
|
my $self = shift;
|
|
|
|
for my $field (@FIELDS) {
|
|
my $val = defined $self->{$field} ? delete $self->{$field} : $DEFAULTS{$field};
|
|
next unless defined $val;
|
|
|
|
my $set = "set_$field";
|
|
$self->$set($val);
|
|
}
|
|
}
|
|
|
|
for my $field (@FIELDS) {
|
|
no strict 'refs';
|
|
|
|
*$field = sub { exists $_[0]->{$field} ? $_[0]->{$field} : () }
|
|
unless exists &{$field};
|
|
|
|
*{"set_$field"} = sub { $_[0]->{$field} = $_[1] }
|
|
unless exists &{"set_$field"};
|
|
}
|
|
|
|
sub can {
|
|
my $self = shift;
|
|
my ($name) = @_;
|
|
return $self->SUPER::can($name) unless $name eq 'callback';
|
|
return $self->{callback} || \&Test2::Event::callback;
|
|
}
|
|
|
|
sub facet_data {
|
|
my $self = shift;
|
|
return $self->{facet_data} || $self->SUPER::facet_data();
|
|
}
|
|
|
|
sub summary {
|
|
my $self = shift;
|
|
return $self->{summary} if defined $self->{summary};
|
|
$self->SUPER::summary();
|
|
}
|
|
|
|
sub sets_plan {
|
|
my $self = shift;
|
|
return unless $self->{sets_plan};
|
|
return @{$self->{sets_plan}};
|
|
}
|
|
|
|
sub callback {
|
|
my $self = shift;
|
|
my $cb = $self->{callback} || return;
|
|
$self->$cb(@_);
|
|
}
|
|
|
|
sub set_global {
|
|
my $self = shift;
|
|
my ($bool) = @_;
|
|
|
|
if(!defined $bool) {
|
|
delete $self->{global};
|
|
return undef;
|
|
}
|
|
|
|
$self->{global} = $bool;
|
|
}
|
|
|
|
sub set_callback {
|
|
my $self = shift;
|
|
my ($cb) = @_;
|
|
|
|
if(!defined $cb) {
|
|
delete $self->{callback};
|
|
return undef;
|
|
}
|
|
|
|
croak "callback must be a code reference"
|
|
unless ref($cb) && reftype($cb) eq 'CODE';
|
|
|
|
$self->{callback} = $cb;
|
|
}
|
|
|
|
sub set_terminate {
|
|
my $self = shift;
|
|
my ($exit) = @_;
|
|
|
|
if(!defined $exit) {
|
|
delete $self->{terminate};
|
|
return undef;
|
|
}
|
|
|
|
croak "terminate must be a positive integer"
|
|
unless $exit =~ m/^\d+$/;
|
|
|
|
$self->{terminate} = $exit;
|
|
}
|
|
|
|
sub set_sets_plan {
|
|
my $self = shift;
|
|
my ($plan) = @_;
|
|
|
|
if(!defined $plan) {
|
|
delete $self->{sets_plan};
|
|
return undef;
|
|
}
|
|
|
|
croak "'sets_plan' must be an array reference"
|
|
unless ref($plan) && reftype($plan) eq 'ARRAY';
|
|
|
|
$self->{sets_plan} = $plan;
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=pod
|
|
|
|
=encoding UTF-8
|
|
|
|
=head1 NAME
|
|
|
|
Test2::Event::Generic - Generic event type.
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This is a generic event that lets you customize all fields in the event API.
|
|
This is useful if you have need for a custom event that does not make sense as
|
|
a published reusable event subclass.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Test2::API qw/context/;
|
|
|
|
sub send_custom_fail {
|
|
my $ctx = shift;
|
|
|
|
$ctx->send_event('Generic', causes_fail => 1, summary => 'The sky is falling');
|
|
|
|
$ctx->release;
|
|
}
|
|
|
|
send_custom_fail();
|
|
|
|
=head1 METHODS
|
|
|
|
=over 4
|
|
|
|
=item $e->facet_data($data)
|
|
|
|
=item $data = $e->facet_data
|
|
|
|
Get or set the facet data (see L<Test2::Event>). If no facet_data is set then
|
|
C<< Test2::Event->facet_data >> will be called to produce facets from the other
|
|
data.
|
|
|
|
=item $e->callback($hub)
|
|
|
|
Call the custom callback if one is set, otherwise this does nothing.
|
|
|
|
=item $e->set_callback(sub { ... })
|
|
|
|
Set the custom callback. The custom callback must be a coderef. The first
|
|
argument to your callback will be the event itself, the second will be the
|
|
L<Test2::Event::Hub> that is using the callback.
|
|
|
|
=item $bool = $e->causes_fail
|
|
|
|
=item $e->set_causes_fail($bool)
|
|
|
|
Get/Set the C<causes_fail> attribute. This defaults to C<0>.
|
|
|
|
=item $bool = $e->diagnostics
|
|
|
|
=item $e->set_diagnostics($bool)
|
|
|
|
Get/Set the C<diagnostics> attribute. This defaults to C<0>.
|
|
|
|
=item $bool_or_undef = $e->global
|
|
|
|
=item @bool_or_empty = $e->global
|
|
|
|
=item $e->set_global($bool_or_undef)
|
|
|
|
Get/Set the C<diagnostics> attribute. This defaults to an empty list which is
|
|
undef in scalar context.
|
|
|
|
=item $bool = $e->increments_count
|
|
|
|
=item $e->set_increments_count($bool)
|
|
|
|
Get/Set the C<increments_count> attribute. This defaults to C<0>.
|
|
|
|
=item $bool = $e->no_display
|
|
|
|
=item $e->set_no_display($bool)
|
|
|
|
Get/Set the C<no_display> attribute. This defaults to C<0>.
|
|
|
|
=item @plan = $e->sets_plan
|
|
|
|
Get the plan if this event sets one. The plan is a list of up to 3 items:
|
|
C<($count, $directive, $reason)>. C<$count> must be defined, the others may be
|
|
undef, or may not exist at all.
|
|
|
|
=item $e->set_sets_plan(\@plan)
|
|
|
|
Set the plan. You must pass in an arrayref with up to 3 elements.
|
|
|
|
=item $summary = $e->summary
|
|
|
|
=item $e->set_summary($summary_or_undef)
|
|
|
|
Get/Set the summary. This will default to the event package
|
|
C<'Test2::Event::Generic'>. You can set it to any value. Setting this to
|
|
C<undef> will reset it to the default.
|
|
|
|
=item $int_or_undef = $e->terminate
|
|
|
|
=item @int_or_empty = $e->terminate
|
|
|
|
=item $e->set_terminate($int_or_undef)
|
|
|
|
This will get/set the C<terminate> attribute. This defaults to undef in scalar
|
|
context, or an empty list in list context. Setting this to undef will clear it
|
|
completely. This must be set to a positive integer (0 or larger).
|
|
|
|
=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
|