5a4214e415d499674d4223ca180cd7a521ca0580
[perl.git] / cpan / Test-Simple / lib / Test2 / Util / Facets2Legacy.pm
1 package Test2::Util::Facets2Legacy;
2 use strict;
3 use warnings;
4
5 our $VERSION = '1.302138';
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 2018 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