1package Test2::EventFacet::Trace;
2use strict;
3use warnings;
4
5our $VERSION = '1.302199';
6
7BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
8
9use Test2::Util qw/get_tid pkg_to_file gen_uid/;
10use Time::HiRes qw/time/;
11use Carp qw/confess/;
12
13use Test2::Util::HashBase qw{^frame ^pid ^tid ^cid -hid -nested details -buffered -uuid -huuid <full_caller <stamp};
14
15{
16    no warnings 'once';
17    *DETAIL = \&DETAILS;
18    *detail = \&details;
19    *set_detail = \&set_details;
20}
21
22sub init {
23    confess "The 'frame' attribute is required"
24        unless $_[0]->{+FRAME};
25
26    $_[0]->{+DETAILS} = delete $_[0]->{detail} if $_[0]->{detail};
27
28    unless (defined($_[0]->{+PID}) || defined($_[0]->{+TID}) || defined($_[0]->{+CID})) {
29        $_[0]->{+PID} = $$        unless defined $_[0]->{+PID};
30        $_[0]->{+TID} = get_tid() unless defined $_[0]->{+TID};
31    }
32}
33
34sub snapshot {
35    my ($orig, @override) = @_;
36    bless {%$orig, @override}, __PACKAGE__;
37}
38
39sub signature {
40    my $self = shift;
41
42    # Signature is only valid if all of these fields are defined, there is no
43    # signature if any is missing. '0' is ok, but '' is not.
44    return join ':' => map { (defined($_) && length($_)) ? $_ : return undef } (
45        $self->{+CID},
46        $self->{+PID},
47        $self->{+TID},
48        $self->{+FRAME}->[1],
49        $self->{+FRAME}->[2],
50    );
51}
52
53sub debug {
54    my $self = shift;
55    return $self->{+DETAILS} if $self->{+DETAILS};
56    my ($pkg, $file, $line) = $self->call;
57    return "at $file line $line";
58}
59
60sub alert {
61    my $self = shift;
62    my ($msg) = @_;
63    warn $msg . ' ' . $self->debug . ".\n";
64}
65
66sub throw {
67    my $self = shift;
68    my ($msg) = @_;
69    die $msg . ' ' . $self->debug . ".\n";
70}
71
72sub call { @{$_[0]->{+FRAME}} }
73
74sub full_call { @{$_[0]->{+FULL_CALLER}} }
75
76sub package { $_[0]->{+FRAME}->[0] }
77sub file    { $_[0]->{+FRAME}->[1] }
78sub line    { $_[0]->{+FRAME}->[2] }
79sub subname { $_[0]->{+FRAME}->[3] }
80
81sub warning_bits { $_[0]->{+FULL_CALLER} ? $_[0]->{+FULL_CALLER}->[9] : undef }
82
831;
84
85__END__
86
87=pod
88
89=encoding UTF-8
90
91=head1 NAME
92
93Test2::EventFacet::Trace - Debug information for events
94
95=head1 DESCRIPTION
96
97The L<Test2::API::Context> object, as well as all L<Test2::Event> types need to
98have access to information about where they were created.  This object
99represents that information.
100
101=head1 SYNOPSIS
102
103    use Test2::EventFacet::Trace;
104
105    my $trace = Test2::EventFacet::Trace->new(
106        frame => [$package, $file, $line, $subname],
107    );
108
109=head1 FACET FIELDS
110
111=over 4
112
113=item $string = $trace->{details}
114
115=item $string = $trace->details()
116
117Used as a custom trace message that will be used INSTEAD of
118C<< at <FILE> line <LINE> >> when calling C<< $trace->debug >>.
119
120=item $frame = $trace->{frame}
121
122=item $frame = $trace->frame()
123
124Get the call frame arrayref.
125
126    [$package, $file, $line, $subname]
127
128=item $int = $trace->{pid}
129
130=item $int = $trace->pid()
131
132The process ID in which the event was generated.
133
134=item $int = $trace->{tid}
135
136=item $int = $trace->tid()
137
138The thread ID in which the event was generated.
139
140=item $id = $trace->{cid}
141
142=item $id = $trace->cid()
143
144The ID of the context that was used to create the event.
145
146=item $uuid = $trace->{uuid}
147
148=item $uuid = $trace->uuid()
149
150The UUID of the context that was used to create the event. (If uuid tagging was
151enabled)
152
153=item ($pkg, $file, $line, $subname) = $trace->call
154
155Get the basic call info as a list.
156
157=item @caller = $trace->full_call
158
159Get the full caller(N) results.
160
161=item $warning_bits = $trace->warning_bits
162
163Get index 9 from the full caller info. This is the warnings_bits field.
164
165The value of this is not portable across perl versions or even processes.
166However it can be used in the process that generated it to reproduce the
167warnings settings in a new scope.
168
169    eval <<EOT;
170    BEGIN { ${^WARNING_BITS} = $trace->warning_bits };
171    ... context's warning settings apply here ...
172    EOT
173
174=back
175
176=head2 DISCOURAGED HUB RELATED FIELDS
177
178These fields were not always set properly by tools. These are B<MOSTLY>
179deprecated by the L<Test2::EventFacet::Hub> facets. These fields are not
180required, and may only reflect the hub that was current when the event was
181created, which is not necessarily the same as the hub the event was sent
182through.
183
184Some tools did do a good job setting these to the correct hub, but you cannot
185always rely on that. Use the 'hubs' facet list instead.
186
187=over 4
188
189=item $hid = $trace->{hid}
190
191=item $hid = $trace->hid()
192
193The ID of the hub that was current when the event was created.
194
195=item $huuid = $trace->{huuid}
196
197=item $huuid = $trace->huuid()
198
199The UUID of the hub that was current when the event was created. (If uuid
200tagging was enabled).
201
202=item $int = $trace->{nested}
203
204=item $int = $trace->nested()
205
206How deeply nested the event is.
207
208=item $bool = $trace->{buffered}
209
210=item $bool = $trace->buffered()
211
212True if the event was buffered and not sent to the formatter independent of a
213parent (This should never be set when nested is C<0> or C<undef>).
214
215=back
216
217=head1 METHODS
218
219B<Note:> All facet frames are also methods.
220
221=over 4
222
223=item $trace->set_detail($msg)
224
225=item $msg = $trace->detail
226
227Used to get/set a custom trace message that will be used INSTEAD of
228C<< at <FILE> line <LINE> >> when calling C<< $trace->debug >>.
229
230C<detail()> is an alias to the C<details> facet field for backwards
231compatibility.
232
233=item $str = $trace->debug
234
235Typically returns the string C<< at <FILE> line <LINE> >>. If C<detail> is set
236then its value will be returned instead.
237
238=item $trace->alert($MESSAGE)
239
240This issues a warning at the frame (filename and line number where
241errors should be reported).
242
243=item $trace->throw($MESSAGE)
244
245This throws an exception at the frame (filename and line number where
246errors should be reported).
247
248=item ($package, $file, $line, $subname) = $trace->call()
249
250Get the caller details for the debug-info. This is where errors should be
251reported.
252
253=item $pkg = $trace->package
254
255Get the debug-info package.
256
257=item $file = $trace->file
258
259Get the debug-info filename.
260
261=item $line = $trace->line
262
263Get the debug-info line number.
264
265=item $subname = $trace->subname
266
267Get the debug-info subroutine name.
268
269=item $sig = trace->signature
270
271Get a signature string that identifies this trace. This is used to check if
272multiple events are related. The signature includes pid, tid, file, line
273number, and the cid.
274
275=back
276
277=head1 SOURCE
278
279The source code repository for Test2 can be found at
280L<https://github.com/Test-More/test-more/>.
281
282=head1 MAINTAINERS
283
284=over 4
285
286=item Chad Granum E<lt>exodist@cpan.orgE<gt>
287
288=back
289
290=head1 AUTHORS
291
292=over 4
293
294=item Chad Granum E<lt>exodist@cpan.orgE<gt>
295
296=back
297
298=head1 COPYRIGHT
299
300Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
301
302This program is free software; you can redistribute it and/or
303modify it under the same terms as Perl itself.
304
305See L<https://dev.perl.org/licenses/>
306
307=cut
308