diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Test2/Event/Generic.pm')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Test2/Event/Generic.pm | 263 |
1 files changed, 263 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Test2/Event/Generic.pm b/Master/tlpkg/tlperl/lib/Test2/Event/Generic.pm new file mode 100755 index 00000000000..ad00f5a963d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Event/Generic.pm @@ -0,0 +1,263 @@ +package Test2::Event::Generic; +use strict; +use warnings; + +use Carp qw/croak/; +use Scalar::Util qw/reftype/; + +our $VERSION = '1.302073'; + +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 +}; +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'; + my $stash = \%{__PACKAGE__ . "::"}; + + *$field = sub { exists $_[0]->{$field} ? $_[0]->{$field} : () } + unless defined $stash->{$field} + && defined *{$stash->{$field}}{CODE}; + + *{"set_$field"} = sub { $_[0]->{$field} = $_[1] } + unless defined $stash->{"set_$field"} + && defined *{$stash->{"set_$field"}}{CODE}; +} + +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->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 2016 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 |