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