Synch with CPAN Test-Simple 1.302140.
[perl.git] / cpan / Test-Simple / lib / Test2 / Event.pm
1 package Test2::Event;
2 use strict;
3 use warnings;
4
5 our $VERSION = '1.302140';
6
7 use Scalar::Util qw/blessed reftype/;
8 use Carp qw/croak/;
9
10 use Test2::Util::HashBase qw/trace -amnesty uuid -_eid -hubs/;
11 use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
12 use Test2::Util qw/pkg_to_file gen_uid/;
13
14 use Test2::EventFacet::About();
15 use Test2::EventFacet::Amnesty();
16 use Test2::EventFacet::Assert();
17 use Test2::EventFacet::Control();
18 use Test2::EventFacet::Error();
19 use Test2::EventFacet::Info();
20 use Test2::EventFacet::Meta();
21 use Test2::EventFacet::Parent();
22 use Test2::EventFacet::Plan();
23 use Test2::EventFacet::Trace();
24 use Test2::EventFacet::Hub();
25
26 # Legacy tools will expect this to be loaded now
27 require Test2::Util::Trace;
28
29 my %LOADED_FACETS = (
30     'about'   => 'Test2::EventFacet::About',
31     'amnesty' => 'Test2::EventFacet::Amnesty',
32     'assert'  => 'Test2::EventFacet::Assert',
33     'control' => 'Test2::EventFacet::Control',
34     'errors'  => 'Test2::EventFacet::Error',
35     'info'    => 'Test2::EventFacet::Info',
36     'meta'    => 'Test2::EventFacet::Meta',
37     'parent'  => 'Test2::EventFacet::Parent',
38     'plan'    => 'Test2::EventFacet::Plan',
39     'trace'   => 'Test2::EventFacet::Trace',
40     'hubs'    => 'Test2::EventFacet::Hub',
41 );
42
43 sub FACET_TYPES { sort values %LOADED_FACETS }
44
45 sub load_facet {
46     my $class = shift;
47     my ($facet) = @_;
48
49     return $LOADED_FACETS{$facet} if exists $LOADED_FACETS{$facet};
50
51     my @check = ($facet);
52     if ('s' eq substr($facet, -1, 1)) {
53         push @check => substr($facet, 0, -1);
54     }
55     else {
56         push @check => $facet . 's';
57     }
58
59     my $found;
60     for my $check (@check) {
61         my $mod  = "Test2::EventFacet::" . ucfirst($facet);
62         my $file = pkg_to_file($mod);
63         next unless eval { require $file; 1 };
64         $found = $mod;
65         last;
66     }
67
68     return undef unless $found;
69     $LOADED_FACETS{$facet} = $found;
70 }
71
72 sub causes_fail      { 0 }
73 sub increments_count { 0 }
74 sub diagnostics      { 0 }
75 sub no_display       { 0 }
76 sub subtest_id       { undef }
77
78 sub callback { }
79
80 sub terminate { () }
81 sub global    { () }
82 sub sets_plan { () }
83
84 sub summary { ref($_[0]) }
85
86 sub related {
87     my $self = shift;
88     my ($event) = @_;
89
90     my $tracea = $self->trace  or return undef;
91     my $traceb = $event->trace or return undef;
92
93     my $uuida = $tracea->uuid;
94     my $uuidb = $traceb->uuid;
95     if ($uuida && $uuidb) {
96         return 1 if $uuida eq $uuidb;
97         return 0;
98     }
99
100     my $siga = $tracea->signature or return undef;
101     my $sigb = $traceb->signature or return undef;
102
103     return 1 if $siga eq $sigb;
104     return 0;
105 }
106
107 sub add_hub {
108     my $self = shift;
109     unshift @{$self->{+HUBS}} => @_;
110 }
111
112 sub add_amnesty {
113     my $self = shift;
114
115     for my $am (@_) {
116         $am = {%$am} if ref($am) ne 'ARRAY';
117         $am = Test2::EventFacet::Amnesty->new($am);
118
119         push @{$self->{+AMNESTY}} => $am;
120     }
121 }
122
123 sub eid { $_[0]->{+_EID} ||= gen_uid() }
124
125 sub common_facet_data {
126     my $self = shift;
127
128     my %out;
129
130     $out{about} = {package => ref($self) || undef};
131     if (my $uuid = $self->uuid) {
132         $out{about}->{uuid} = $uuid;
133     }
134
135     $out{about}->{eid} = $self->{+_EID} || $self->eid;
136
137     if (my $trace = $self->trace) {
138         $out{trace} = { %$trace };
139     }
140
141     if (my $hubs = $self->hubs) {
142         $out{hubs} = $hubs;
143     }
144
145     $out{amnesty} = [map {{ %{$_} }} @{$self->{+AMNESTY}}]
146         if $self->{+AMNESTY};
147
148     if (my $meta = $self->meta_facet_data) {
149         $out{meta} = $meta;
150     }
151
152     return \%out;
153 }
154
155 sub meta_facet_data {
156     my $self = shift;
157
158     my $key = Test2::Util::ExternalMeta::META_KEY();
159
160     my $hash = $self->{$key} or return undef;
161     return {%$hash};
162 }
163
164 sub facet_data {
165     my $self = shift;
166
167     my $out = $self->common_facet_data;
168
169     $out->{about}->{details}    = $self->summary    || undef;
170     $out->{about}->{no_display} = $self->no_display || undef;
171
172     # Might be undef, we want to preserve that
173     my $terminate = $self->terminate;
174     $out->{control} = {
175         global    => $self->global    || 0,
176         terminate => $terminate,
177         has_callback => $self->can('callback') == \&callback ? 0 : 1,
178     };
179
180     $out->{assert} = {
181         no_debug => 1,                     # Legacy behavior
182         pass     => $self->causes_fail ? 0 : 1,
183         details  => $self->summary,
184     } if $self->increments_count;
185
186     $out->{parent} = {hid => $self->subtest_id} if $self->subtest_id;
187
188     if (my @plan = $self->sets_plan) {
189         $out->{plan} = {};
190
191         $out->{plan}->{count}   = $plan[0] if defined $plan[0];
192         $out->{plan}->{details} = $plan[2] if defined $plan[2];
193
194         if ($plan[1]) {
195             $out->{plan}->{skip} = 1 if $plan[1] eq 'SKIP';
196             $out->{plan}->{none} = 1 if $plan[1] eq 'NO PLAN';
197         }
198
199         $out->{control}->{terminate} ||= 0 if $out->{plan}->{skip};
200     }
201
202     if ($self->causes_fail && !$out->{assert}) {
203         $out->{errors} = [
204             {
205                 tag     => 'FAIL',
206                 fail    => 1,
207                 details => $self->summary,
208             }
209         ];
210     }
211
212     my %IGNORE = (trace => 1, about => 1, control => 1);
213     my $do_info = !grep { !$IGNORE{$_} } keys %$out;
214
215     if ($do_info && !$self->no_display && $self->diagnostics) {
216         $out->{info} = [
217             {
218                 tag     => 'DIAG',
219                 debug   => 1,
220                 details => $self->summary,
221             }
222         ];
223     }
224
225     return $out;
226 }
227
228 sub facets {
229     my $self = shift;
230     my %out;
231
232     my $data = $self->facet_data;
233     my @errors = $self->validate_facet_data($data);
234     die join "\n" => @errors if @errors;
235
236     for my $facet (keys %$data) {
237         my $class = $self->load_facet($facet);
238         my $val = $data->{$facet};
239
240         unless($class) {
241             $out{$facet} = $val;
242             next;
243         }
244
245         my $is_list = reftype($val) eq 'ARRAY' ? 1 : 0;
246         if ($is_list) {
247             $out{$facet} = [map { $class->new($_) } @$val];
248         }
249         else {
250             $out{$facet} = $class->new($val);
251         }
252     }
253
254     return \%out;
255 }
256
257 sub validate_facet_data {
258     my $class_or_self = shift;
259     my ($f, %params);
260
261     $f = shift if @_ && (reftype($_[0]) || '') eq 'HASH';
262     %params = @_;
263
264     $f ||= $class_or_self->facet_data if blessed($class_or_self);
265     croak "No facet data" unless $f;
266
267     my @errors;
268
269     for my $k (sort keys %$f) {
270         my $fclass = $class_or_self->load_facet($k);
271
272         push @errors => "Could not find a facet class for facet '$k'"
273             if $params{require_facet_class} && !$fclass;
274
275         next unless $fclass;
276
277         my $v = $f->{$k};
278         next unless defined($v); # undef is always fine
279
280         my $is_list = $fclass->is_list();
281         my $got_list = reftype($v) eq 'ARRAY' ? 1 : 0;
282
283         push @errors => "Facet '$k' should be a list, but got a single item ($v)"
284             if $is_list && !$got_list;
285
286         push @errors => "Facet '$k' should not be a list, but got a a list ($v)"
287             if $got_list && !$is_list;
288     }
289
290     return @errors;
291 }
292
293 sub nested {
294     my $self = shift;
295
296     Carp::cluck("Use of Test2::Event->nested() is deprecated, use Test2::Event->trace->nested instead")
297         if $ENV{AUTHOR_TESTING};
298
299     if (my $hubs = $self->{+HUBS}) {
300         return $hubs->[0]->{nested} if @$hubs;
301     }
302
303     my $trace = $self->{+TRACE} or return undef;
304     return $trace->{nested};
305 }
306
307 sub in_subtest {
308     my $self = shift;
309
310     Carp::cluck("Use of Test2::Event->in_subtest() is deprecated, use Test2::Event->trace->hid instead")
311         if $ENV{AUTHOR_TESTING};
312
313     my $hubs = $self->{+HUBS};
314     if ($hubs && @$hubs) {
315         return undef unless $hubs->[0]->{nested};
316         return $hubs->[0]->{hid}
317     }
318
319     my $trace = $self->{+TRACE} or return undef;
320     return undef unless $trace->{nested};
321     return $trace->{hid};
322 }
323
324 1;
325
326 __END__
327
328 =pod
329
330 =encoding UTF-8
331
332 =head1 NAME
333
334 Test2::Event - Base class for events
335
336 =head1 DESCRIPTION
337
338 Base class for all event objects that get passed through
339 L<Test2>.
340
341 =head1 SYNOPSIS
342
343     package Test2::Event::MyEvent;
344     use strict;
345     use warnings;
346
347     # This will make our class an event subclass (required)
348     use base 'Test2::Event';
349
350     # Add some accessors (optional)
351     # You are not obligated to use HashBase, you can use any object tool you
352     # want, or roll your own accessors.
353     use Test2::Util::HashBase qw/foo bar baz/;
354
355     # Use this if you want the legacy API to be written for you, for this to
356     # work you will need to implement a facet_data() method.
357     use Test2::Util::Facets2Legacy;
358
359     # Chance to initialize some defaults
360     sub init {
361         my $self = shift;
362         # no other args in @_
363
364         $self->set_foo('xxx') unless defined $self->foo;
365
366         ...
367     }
368
369     # This is the new way for events to convey data to the Test2 system
370     sub facet_data {
371         my $self = shift;
372
373         # Get common facets such as 'about', 'trace' 'amnesty', and 'meta'
374         my $facet_data = $self->common_facet_data();
375
376         # Are you making an assertion?
377         $facet_data->{assert} = {pass => 1, details => 'my assertion'};
378         ...
379
380         return $facet_data;
381     }
382
383     1;
384
385 =head1 METHODS
386
387 =head2 GENERAL
388
389 =over 4
390
391 =item $trace = $e->trace
392
393 Get a snapshot of the L<Test2::EventFacet::Trace> as it was when this event was
394 generated
395
396 =item $bool_or_undef = $e->related($e2)
397
398 Check if 2 events are related. In this case related means their traces share a
399 signature meaning they were created with the same context (or at the very least
400 by contexts which share an id, which is the same thing unless someone is doing
401 something very bad).
402
403 This can be used to reliably link multiple events created by the same tool. For
404 instance a failing test like C<ok(0, "fail"> will generate 2 events, one being
405 a L<Test2::Event::Ok>, the other being a L<Test2::Event::Diag>, both of these
406 events are related having been created under the same context and by the same
407 initial tool (though multiple tools may have been nested under the initial
408 one).
409
410 This will return C<undef> if the relationship cannot be checked, which happens
411 if either event has an incomplete or missing trace. This will return C<0> if
412 the traces are complete, but do not match. C<1> will be returned if there is a
413 match.
414
415 =item $e->add_amnesty({tag => $TAG, details => $DETAILS});
416
417 This can be used to add amnesty to this event. Amnesty only effects failing
418 assertions in most cases, but some formatters may display them for passing
419 assertions, or even non-assertions as well.
420
421 Amnesty will prevent a failed assertion from causing the overall test to fail.
422 In other words it marks a failure as expected and allowed.
423
424 B<Note:> This is how 'TODO' is implemented under the hood. TODO is essentially
425 amnesty with the 'TODO' tag. The details are the reason for the TODO.
426
427 =item $uuid = $e->uuid
428
429 If UUID tagging is enabled (See L<Test::API>) then any event that has made its
430 way through a hub will be tagged with a UUID. A newly created event will not
431 yet be tagged in most cases.
432
433 =item $class = $e->load_facet($name)
434
435 This method is used to load a facet by name (or key). It will attempt to load
436 the facet class, if it succeeds it will return the class it loaded. If it fails
437 it will return C<undef>. This caches the result at the class level so that
438 future calls will be faster.
439
440 The C<$name> variable should be the key used to access the facet in a facets
441 hashref. For instance the assertion facet has the key 'assert', the information
442 facet has the 'info' key, and the error facet has the key 'errors'. You may
443 include or omit the 's' at the end of the name, the method is smart enough to
444 try both the 's' and no-'s' forms, it will check what you provided first, and
445 if that is not found it will add or strip the 's and try again.
446
447 =item @classes = $e->FACET_TYPES()
448
449 =item @classes = Test2::Event->FACET_TYPES()
450
451 This returns a list of all facets that have been loaded using the
452 C<load_facet()> method. This will not return any classes that have not been
453 loaded, or have been loaded directly without a call to C<load_facet()>.
454
455 B<Note:> The core facet types are automatically loaded and populated in this
456 list.
457
458 =back
459
460 =head2 NEW API
461
462 =over 4
463
464 =item $hashref = $e->common_facet_data();
465
466 This can be used by subclasses to generate a starting facet data hashref. This
467 will populate the hashref with the trace, meta, amnesty, and about facets.
468 These facets are nearly always produced the same way for all events.
469
470 =item $hashref = $e->facet_data()
471
472 If you do not override this then the default implementation will attempt to
473 generate facets from the legacy API. This generation is limited only to what
474 the legacy API can provide. It is recommended that you override this method and
475 write out explicit facet data.
476
477 =item $hashref = $e->facets()
478
479 This takes the hashref from C<facet_data()> and blesses each facet into the
480 proper C<Test2::EventFacet::*> subclass. If no class can be found for any given
481 facet it will be passed along unchanged.
482
483 =item @errors = $e->validate_facet_data();
484
485 =item @errors = $e->validate_facet_data(%params);
486
487 =item @errors = $e->validate_facet_data(\%facets, %params);
488
489 =item @errors = Test2::Event->validate_facet_data(%params);
490
491 =item @errors = Test2::Event->validate_facet_data(\%facets, %params);
492
493 This method will validate facet data and return a list of errors. If no errors
494 are found this will return an empty list.
495
496 This can be called as an object method with no arguments, in which case the
497 C<facet_data()> method will be called to get the facet data to be validated.
498
499 When used as an object method the C<\%facet_data> argument may be omitted.
500
501 When used as a class method the C<\%facet_data> argument is required.
502
503 Remaining arguments will be slurped into a C<%params> hash.
504
505 Currently only 1 parameter is defined:
506
507 =over 4
508
509 =item require_facet_class => $BOOL
510
511 When set to true (default is false) this will reject any facets where a facet
512 class cannot be found. Normally facets without classes are assumed to be custom
513 and are ignored.
514
515 =back
516
517 =back
518
519 =head3 WHAT ARE FACETS?
520
521 Facets are how events convey their purpose to the Test2 internals and
522 formatters. An event without facets will have no intentional effect on the
523 overall test state, and will not be displayed at all by most formatters, except
524 perhaps to say that an event of an unknown type was seen.
525
526 Facets are produced by the C<facet_data()> subroutine, which you should
527 nearly-always override. C<facet_data()> is expected to return a hashref where
528 each key is the facet type, and the value is either a hashref with the data for
529 that facet, or an array of hashref's. Some facets must be defined as single
530 hashrefs, some must be defined as an array of hashrefs, No facets allow both.
531
532 C<facet_data()> B<MUST NOT> bless the data it returns, the main hashref, and
533 nested facet hashref's B<MUST> be bare, though items contained within each
534 facet may be blessed. The data returned by this method B<should> also be copies
535 of the internal data in order to prevent accidental state modification.
536
537 C<facets()> takes the data from C<facet_data()> and blesses it into the
538 C<Test2::EventFacet::*> packages. This is rarely used however, the EventFacet
539 packages are primarily for convenience and documentation. The EventFacet
540 classes are not used at all internally, instead the raw data is used.
541
542 Here is a list of facet types by package. The packages are not used internally,
543 but are where the documentation for each type is kept.
544
545 B<Note:> Every single facet type has the C<'details'> field. This field is
546 always intended for human consumption, and when provided, should explain the
547 'why' for the facet. All other fields are facet specific.
548
549 =over 4
550
551 =item about => {...}
552
553 L<Test2::EventFacet::About>
554
555 This contains information about the event itself such as the event package
556 name. The C<details> field for this facet is an overall summary of the event.
557
558 =item assert => {...}
559
560 L<Test2::EventFacet::Assert>
561
562 This facet is used if an assertion was made. The C<details> field of this facet
563 is the description of the assertion.
564
565 =item control => {...}
566
567 L<Test2::EventFacet::Control>
568
569 This facet is used to tell the L<Test2::Event::Hub> about special actions the
570 event causes. Things like halting all testing, terminating the current test,
571 etc. In this facet the C<details> field explains why any special action was
572 taken.
573
574 B<Note:> This is how bail-out is implemented.
575
576 =item meta => {...}
577
578 L<Test2::EventFacet::Meta>
579
580 The meta facet contains all the meta-data attached to the event. In this case
581 the C<details> field has no special meaning, but may be present if something
582 sets the 'details' meta-key on the event.
583
584 =item parent => {...}
585
586 L<Test2::EventFacet::Parent>
587
588 This facet contains nested events and similar details for subtests. In this
589 facet the C<details> field will typically be the name of the subtest.
590
591 =item plan => {...}
592
593 L<Test2::EventFacet::Plan>
594
595 This facet tells the system that a plan has been set. The C<details> field of
596 this is usually left empty, but when present explains why the plan is what it
597 is, this is most useful if the plan is to skip-all.
598
599 =item trace => {...}
600
601 L<Test2::EventFacet::Trace>
602
603 This facet contains information related to when and where the event was
604 generated. This is how the test file and line number of a failure is known.
605 This facet can also help you to tell if tests are related.
606
607 In this facet the C<details> field overrides the "failed at test_file.t line
608 42." message provided on assertion failure.
609
610 =item amnesty => [{...}, ...]
611
612 L<Test2::EventFacet::Amnesty>
613
614 The amnesty facet is a list instead of a single item, this is important as
615 amnesty can come from multiple places at once.
616
617 For each instance of amnesty the C<details> field explains why amnesty was
618 granted.
619
620 B<Note:> Outside of formatters amnesty only acts to forgive a failing
621 assertion.
622
623 =item errors => [{...}, ...]
624
625 L<Test2::EventFacet::Error>
626
627 The errors facet is a list instead of a single item, any number of errors can
628 be listed. In this facet C<details> describes the error, or may contain the raw
629 error message itself (such as an exception). In perl exception may be blessed
630 objects, as such the raw data for this facet may contain nested items which are
631 blessed.
632
633 Not all errors are considered fatal, there is a C<fail> field that must be set
634 for an error to cause the test to fail.
635
636 B<Note:> This facet is unique in that the field name is 'errors' while the
637 package is 'Error'. This is because this is the only facet type that is both a
638 list, and has a name where the plural is not the same as the singular. This may
639 cause some confusion, but I feel it will be less confusing than the
640 alternative.
641
642 =item info => [{...}, ...]
643
644 L<Test2::EventFacet::Info>
645
646 The 'info' facet is a list instead of a single item, any quantity of extra
647 information can be attached to an event. Some information may be critical
648 diagnostics, others may be simply commentary in nature, this is determined by
649 the C<debug> flag.
650
651 For this facet the C<details> flag is the info itself. This info may be a
652 string, or it may be a data structure to display. This is one of the few facet
653 types that may contain blessed items.
654
655 =back
656
657 =head2 LEGACY API
658
659 =over 4
660
661 =item $bool = $e->causes_fail
662
663 Returns true if this event should result in a test failure. In general this
664 should be false.
665
666 =item $bool = $e->increments_count
667
668 Should be true if this event should result in a test count increment.
669
670 =item $e->callback($hub)
671
672 If your event needs to have extra effects on the L<Test2::Hub> you can override
673 this method.
674
675 This is called B<BEFORE> your event is passed to the formatter.
676
677 =item $num = $e->nested
678
679 If this event is nested inside of other events, this should be the depth of
680 nesting. (This is mainly for subtests)
681
682 =item $bool = $e->global
683
684 Set this to true if your event is global, that is ALL threads and processes
685 should see it no matter when or where it is generated. This is not a common
686 thing to want, it is used by bail-out and skip_all to end testing.
687
688 =item $code = $e->terminate
689
690 This is called B<AFTER> your event has been passed to the formatter. This
691 should normally return undef, only change this if your event should cause the
692 test to exit immediately.
693
694 If you want this event to cause the test to exit you should return the exit
695 code here. Exit code of 0 means exit success, any other integer means exit with
696 failure.
697
698 This is used by L<Test2::Event::Plan> to exit 0 when the plan is
699 'skip_all'. This is also used by L<Test2::Event:Bail> to force the test
700 to exit with a failure.
701
702 This is called after the event has been sent to the formatter in order to
703 ensure the event is seen and understood.
704
705 =item $msg = $e->summary
706
707 This is intended to be a human readable summary of the event. This should
708 ideally only be one line long, but you can use multiple lines if necessary. This
709 is intended for human consumption. You do not need to make it easy for machines
710 to understand.
711
712 The default is to simply return the event package name.
713
714 =item ($count, $directive, $reason) = $e->sets_plan()
715
716 Check if this event sets the testing plan. It will return an empty list if it
717 does not. If it does set the plan it will return a list of 1 to 3 items in
718 order: Expected Test Count, Test Directive, Reason for directive.
719
720 =item $bool = $e->diagnostics
721
722 True if the event contains diagnostics info. This is useful because a
723 non-verbose harness may choose to hide events that are not in this category.
724 Some formatters may choose to send these to STDERR instead of STDOUT to ensure
725 they are seen.
726
727 =item $bool = $e->no_display
728
729 False by default. This will return true on events that should not be displayed
730 by formatters.
731
732 =item $id = $e->in_subtest
733
734 If the event is inside a subtest this should have the subtest ID.
735
736 =item $id = $e->subtest_id
737
738 If the event is a final subtest event, this should contain the subtest ID.
739
740 =back
741
742 =head1 THIRD PARTY META-DATA
743
744 This object consumes L<Test2::Util::ExternalMeta> which provides a consistent
745 way for you to attach meta-data to instances of this class. This is useful for
746 tools, plugins, and other extensions.
747
748 =head1 SOURCE
749
750 The source code repository for Test2 can be found at
751 F<http://github.com/Test-More/test-more/>.
752
753 =head1 MAINTAINERS
754
755 =over 4
756
757 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
758
759 =back
760
761 =head1 AUTHORS
762
763 =over 4
764
765 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
766
767 =back
768
769 =head1 COPYRIGHT
770
771 Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
772
773 This program is free software; you can redistribute it and/or
774 modify it under the same terms as Perl itself.
775
776 See F<http://dev.perl.org/licenses/>
777
778 =cut