cpan/Test-Simple/lib/Test2/Util/Facets2Legacy.pm

   1 package Test2::Util::Facets2Legacy;
   2 use strict;
   3 use warnings;
   4
   5 our $VERSION = '1.302185';
   6
   7 use Carp qw/croak confess/;
   8 use Scalar::Util qw/blessed/;
   9
  10 use base 'Exporter';
  11 our @EXPORT_OK = qw{
  12     causes_fail
  13     diagnostics
  14     global
  15     increments_count
  16     no_display
  17     sets_plan
  18     subtest_id
  19     summary
  20     terminate
  21     uuid
  22 };
  23 our %EXPORT_TAGS = ( ALL => \@EXPORT_OK );
  24
  25 our $CYCLE_DETECT = 0;
  26 sub _get_facet_data {
  27     my $in = shift;
  28
  29     if (blessed($in) && $in->isa('Test2::Event')) {
  30         confess "Cycle between Facets2Legacy and $in\->facet_data() (Did you forget to override the facet_data() method?)"
  31             if $CYCLE_DETECT;
  32
  33         local $CYCLE_DETECT = 1;
  34         return $in->facet_data;
  35     }
  36
  37     return $in if ref($in) eq 'HASH';
  38
  39     croak "'$in' Does not appear to be either a Test::Event or an EventFacet hashref";
  40 }
  41
  42 sub causes_fail {
  43     my $facet_data = _get_facet_data(shift @_);
  44
  45     return 1 if $facet_data->{errors} && grep { $_->{fail} } @{$facet_data->{errors}};
  46
  47     if (my $control = $facet_data->{control}) {
  48         return 1 if $control->{halt};
  49         return 1 if $control->{terminate};
  50     }
  51
  52     return 0 if $facet_data->{amnesty} && @{$facet_data->{amnesty}};
  53     return 1 if $facet_data->{assert} && !$facet_data->{assert}->{pass};
  54     return 0;
  55 }
  56
  57 sub diagnostics {
  58     my $facet_data = _get_facet_data(shift @_);
  59     return 1 if $facet_data->{errors} && @{$facet_data->{errors}};
  60     return 0 unless $facet_data->{info} && @{$facet_data->{info}};
  61     return (grep { $_->{debug} } @{$facet_data->{info}}) ? 1 : 0;
  62 }
  63
  64 sub global {
  65     my $facet_data = _get_facet_data(shift @_);
  66     return 0 unless $facet_data->{control};
  67     return $facet_data->{control}->{global};
  68 }
  69
  70 sub increments_count {
  71     my $facet_data = _get_facet_data(shift @_);
  72     return $facet_data->{assert} ? 1 : 0;
  73 }
  74
  75 sub no_display {
  76     my $facet_data = _get_facet_data(shift @_);
  77     return 0 unless $facet_data->{about};
  78     return $facet_data->{about}->{no_display};
  79 }
  80
  81 sub sets_plan {
  82     my $facet_data = _get_facet_data(shift @_);
  83     my $plan = $facet_data->{plan} or return;
  84     my @out = ($plan->{count} || 0);
  85
  86     if ($plan->{skip}) {
  87         push @out => 'SKIP';
  88         push @out => $plan->{details} if defined $plan->{details};
  89     }
  90     elsif ($plan->{none}) {
  91         push @out => 'NO PLAN'
  92     }
  93
  94     return @out;
  95 }
  96
  97 sub subtest_id {
  98     my $facet_data = _get_facet_data(shift @_);
  99     return undef unless $facet_data->{parent};
 100     return $facet_data->{parent}->{hid};
 101 }
 102
 103 sub summary {
 104     my $facet_data = _get_facet_data(shift @_);
 105     return '' unless $facet_data->{about} && $facet_data->{about}->{details};
 106     return $facet_data->{about}->{details};
 107 }
 108
 109 sub terminate {
 110     my $facet_data = _get_facet_data(shift @_);
 111     return undef unless $facet_data->{control};
 112     return $facet_data->{control}->{terminate};
 113 }
 114
 115 sub uuid {
 116     my $in = shift;
 117
 118     if ($CYCLE_DETECT) {
 119         if (blessed($in) && $in->isa('Test2::Event')) {
 120             my $meth = $in->can('uuid');
 121             $meth = $in->can('SUPER::uuid') if $meth == \&uuid;
 122             my $uuid = $in->$meth if $meth && $meth != \&uuid;
 123             return $uuid if $uuid;
 124         }
 125
 126         return undef;
 127     }
 128
 129     my $facet_data = _get_facet_data($in);
 130     return $facet_data->{about}->{uuid} if $facet_data->{about} && $facet_data->{about}->{uuid};
 131
 132     return undef;
 133 }
 134
 135 1;
 136
 137 =pod
 138
 139 =encoding UTF-8
 140
 141 =head1 NAME
 142
 143 Test2::Util::Facets2Legacy - Convert facet data to the legacy event API.
 144
 145 =head1 DESCRIPTION
 146
 147 This module exports several subroutines from the older event API (see
 148 L<Test2::Event>). These subroutines can be used as methods on any object that
 149 provides a custom C<facet_data()> method. These subroutines can also be used as
 150 functions that take a facet data hashref as arguments.
 151
 152 =head1 SYNOPSIS
 153
 154 =head2 AS METHODS
 155
 156     package My::Event;
 157
 158     use Test2::Util::Facets2Legacy ':ALL';
 159
 160     sub facet_data { return { ... } }
 161
 162 Then to use it:
 163
 164     my $e = My::Event->new(...);
 165
 166     my $causes_fail = $e->causes_fail;
 167     my $summary     = $e->summary;
 168     ....
 169
 170 =head2 AS FUNCTIONS
 171
 172     use Test2::Util::Facets2Legacy ':ALL';
 173
 174     my $f = {
 175         assert => { ... },
 176         info => [{...}, ...],
 177         control => {...},
 178         ...
 179     };
 180
 181     my $causes_fail = causes_fail($f);
 182     my $summary     = summary($f);
 183
 184 =head1 NOTE ON CYCLES
 185
 186 When used as methods, all these subroutines call C<< $e->facet_data() >>. The
 187 default C<facet_data()> method in L<Test2::Event> relies on the legacy methods
 188 this module emulates in order to work. As a result of this it is very easy to
 189 create infinite recursion bugs.
 190
 191 These methods have cycle detection and will throw an exception early if a cycle
 192 is detected. C<uuid()> is currently the only subroutine in this library that
 193 has a fallback behavior when cycles are detected.
 194
 195 =head1 EXPORTS
 196
 197 Nothing is exported by default. You must specify which methods to import, or
 198 use the ':ALL' tag.
 199
 200 =over 4
 201
 202 =item $bool = $e->causes_fail()
 203
 204 =item $bool = causes_fail($f)
 205
 206 Check if the event or facets result in a failing state.
 207
 208 =item $bool = $e->diagnostics()
 209
 210 =item $bool = diagnostics($f)
 211
 212 Check if the event or facets contain any diagnostics information.
 213
 214 =item $bool = $e->global()
 215
 216 =item $bool = global($f)
 217
 218 Check if the event or facets need to be globally processed.
 219
 220 =item $bool = $e->increments_count()
 221
 222 =item $bool = increments_count($f)
 223
 224 Check if the event or facets make an assertion.
 225
 226 =item $bool = $e->no_display()
 227
 228 =item $bool = no_display($f)
 229
 230 Check if the event or facets should be rendered or hidden.
 231
 232 =item ($max, $directive, $reason) = $e->sets_plan()
 233
 234 =item ($max, $directive, $reason) = sets_plan($f)
 235
 236 Check if the event or facets set a plan, and return the plan details.
 237
 238 =item $id = $e->subtest_id()
 239
 240 =item $id = subtest_id($f)
 241
 242 Get the subtest id, if any.
 243
 244 =item $string = $e->summary()
 245
 246 =item $string = summary($f)
 247
 248 Get the summary of the event or facets hash, if any.
 249
 250 =item $undef_or_int = $e->terminate()
 251
 252 =item $undef_or_int = terminate($f)
 253
 254 Check if the event or facets should result in process termination, if so the
 255 exit code is returned (which could be 0). undef is returned if no termination
 256 is requested.
 257
 258 =item $uuid = $e->uuid()
 259
 260 =item $uuid = uuid($f)
 261
 262 Get the UUID of the facets or event.
 263
 264 B<Note:> This will fall back to C<< $e->SUPER::uuid() >> if a cycle is
 265 detected and an event is used as the argument.
 266
 267 =back
 268
 269 =head1 SOURCE
 270
 271 The source code repository for Test2 can be found at
 272 F<http://github.com/Test-More/test-more/>.
 273
 274 =head1 MAINTAINERS
 275
 276 =over 4
 277
 278 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
 279
 280 =back
 281
 282 =head1 AUTHORS
 283
 284 =over 4
 285
 286 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
 287
 288 =back
 289
 290 =head1 COPYRIGHT
 291
 292 Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
 293
 294 This program is free software; you can redistribute it and/or
 295 modify it under the same terms as Perl itself.
 296
 297 See F<http://dev.perl.org/licenses/>
 298
 299 =cut