File Coverage

blib/lib/OpenTracing/Tracer.pm
Criterion Covered Total %
statement 78 137 56.9
branch 9 36 25.0
condition 11 28 39.2
subroutine 21 34 61.7
pod 7 20 35.0
total 126 255 49.4


line stmt bran cond sub pod time code
1             package OpenTracing::Tracer;
2              
3 3     3   83256 use strict;
  3         16  
  3         96  
4 3     3   18 use warnings;
  3         5  
  3         145  
5              
6             our $VERSION = '1.005'; # VERSION
7             our $AUTHORITY = 'cpan:TEAM'; # AUTHORITY
8              
9 3     3   511 no indirect;
  3         1236  
  3         16  
10 3     3   810 use utf8;
  3         25  
  3         18  
11              
12             =encoding utf8
13              
14             =head1 NAME
15              
16             OpenTracing::Tracer - application tracing
17              
18             =head1 DESCRIPTION
19              
20             This provides the interface between the OpenTracing API and the tracing service(s)
21             for an application.
22              
23             Typically a single process would have one tracer instance.
24              
25             =cut
26              
27 3     3   526 use OpenTracing::Process;
  3         8  
  3         91  
28 3     3   424 use OpenTracing::Span;
  3         5  
  3         108  
29 3     3   447 use OpenTracing::SpanProxy;
  3         8  
  3         95  
30 3     3   1327 use OpenTracing::Reference;
  3         6  
  3         128  
31              
32 3     3   19 use List::Util qw(min);
  3         5  
  3         352  
33 3     3   21 use Scalar::Util qw(refaddr);
  3         6  
  3         132  
34 3     3   16 use Time::HiRes ();
  3         5  
  3         83  
35              
36 3     3   1055 use Log::Any qw($log);
  3         19112  
  3         20  
37              
38             =head1 METHODS
39              
40             =cut
41              
42             sub new {
43 3     3 0 165 my ($class, %args) = @_;
44 3   50     31 $args{span_completion_callbacks} ||= [];
45 3   50     20 $args{current_span} ||= [];
46 3         14 bless \%args, $class
47             }
48              
49             =head2 process
50              
51             Returns the current L.
52              
53             =cut
54              
55             sub process {
56 1     1 1 625 my ($self) = @_;
57              
58             # Handle forks
59 1 50 33     8 if($self->{process} and $self->{process}->pid != $$) {
60 0         0 delete $self->{process};
61             }
62              
63 1   33     5 $self->{process} //= do {
64 1         564 require Net::Address::IP::Local;
65 1   0     9681 OpenTracing::Process->new(
      33        
66             tags => {
67             pid => $$,
68             ip => Net::Address::IP::Local->public_ipv4,
69             # When running from the repository, we won't have a ->VERSION, so
70             # we'll default to the main package but indicate with -dev that
71             # we may have differences from the "official" version
72             'tracer.version' => 'perl-OpenTracing-' . (__PACKAGE__->VERSION // ((OpenTracing->VERSION // "unknown") . "-dev")),
73             }
74             );
75             }
76             }
77              
78             =head2 is_enabled
79              
80             Returns true if this tracer is currently enabled.
81              
82             =cut
83              
84 8   100 8 1 35 sub is_enabled { shift->{is_enabled} //= 0 }
85              
86             =head2 enable
87              
88             Enable the current tracer.
89              
90             =cut
91              
92 1     1 1 933 sub enable { shift->{is_enabled} = 1 }
93              
94             =head2 disable
95              
96             Disable the current tracer.
97              
98             =cut
99              
100 0     0 1 0 sub disable { shift->{is_enabled} = 0 }
101              
102             =head2 spans
103              
104             Returns an arrayref of L instances.
105              
106             =cut
107              
108             sub spans {
109             shift->{spans}
110 1     1 1 6 }
111              
112             =head2 span_list
113              
114             Returns a list of L instances.
115              
116             =cut
117              
118             sub span_list {
119 0   0 0 1 0 (shift->{spans} //= [])->@*
120             }
121              
122             =head2 add_span
123              
124             Adds a new L instance to the pending list, if
125             we're currently enabled.
126              
127             =cut
128              
129             sub add_span {
130 4     4 1 10 my ($self, $span) = @_;
131 4 100       14 return $span unless $self->is_enabled;
132 2         9 push $self->{spans}->@*, $span;
133 2         21 Scalar::Util::weaken($span->{batch});
134 2         6 $span
135             }
136              
137             sub span {
138 4     4 0 997 my ($self, %args) = @_;
139 4   66     42 $args{operation_name} //= (caller 1)[3];
140              
141             # We want to figure out what parent to
142             # use, following as precedence order:
143             # - Parent args
144             # - First CHILD_OF reference
145             # - First FOLLOW_FROM reference
146             # - Current trace span
147 4         12 my $parent = $args{parent};
148 4 50       13 unless ($parent)
149             {
150 4         11 my @reference_queue = ();
151              
152             # Default to current span if any
153 4 100       21 if (my $current_span = $self->{current_span}->[-1])
154             {
155 1         30 push @reference_queue, {
156             id => $current_span->id,
157             trace_id => $current_span->trace_id
158             };
159             }
160              
161 4 50       14 if(my $references = $args{references}) {
162 0         0 foreach my $reference (@$references) {
163 0 0       0 next unless $reference; # skip empty references if any
164              
165 0         0 push @reference_queue, {
166             id => $reference->context->id,
167             trace_id => $reference->context->trace_id
168             };
169              
170             # Stop the loop if CHILD_OF is found
171 0 0       0 last if $reference->ref_type == OpenTracing::Reference::CHILD_OF;
172              
173             # Otherwise loop over FOLLOWS_FROM just in case we find a CHILD_OF later
174             }
175             }
176              
177             # Take the first found reference (either CHILD_OF or FOLLOWS_FROM) or PARENT)
178 4         11 $parent = shift @reference_queue;
179             }
180              
181             $self->add_span(
182 4         58 my $span = OpenTracing::Span->new(
183             tracer => $self,
184             parent => $parent,
185             %args
186             )
187             );
188 4         11 push @{ $self->{current_span} }, $span;
  4         109  
189 4         50 return OpenTracing::SpanProxy->new(span => $span);
190             }
191              
192 0     0 0 0 sub current_span { shift->{current_span}->[-1] }
193              
194             sub finish_span {
195 4     4 0 11 my ($self, $span) = @_;
196 4         20 $log->tracef('Finishing span %s', $span);
197              
198 4         16 @{ $self->{current_span} } = grep { refaddr($_) != refaddr($span)} @{ $self->{current_span} };
  4         31  
  5         25  
  4         11  
199              
200 4   100     8 push @{$self->{finished_spans} //= []}, $span;
  4         19  
201 4 100       16 return $span unless $self->is_enabled;
202              
203 2         16 $_->($span) for $self->span_completion_callbacks;
204 2         6 return $span;
205             }
206              
207             sub add_span_completion_callback {
208 0     0 0 0 my ($self, $code) = @_;
209 0         0 push $self->{span_completion_callbacks}->@*, $code;
210 0         0 return $self;
211             }
212              
213             sub remove_span_completion_callback {
214 0     0 0 0 my ($self, $code) = @_;
215 0         0 my $addr = Scalar::Util::refaddr($code);
216 0         0 my $data = $self->{span_completion_callbacks};
217             # Essentially extract_by from List::UtilsBy
218 0         0 for(my $idx = 0; ; ++$idx) {
219 0 0       0 last if $idx > $#$data;
220 0 0       0 next unless Scalar::Util::refaddr($data->[$idx]) == $addr;
221 0         0 splice @$data, $idx, 1, ();
222             # Skip the $idx change
223 0         0 redo;
224             }
225 0         0 return $self;
226             }
227              
228             sub span_completion_callbacks {
229             shift->{span_completion_callbacks}->@*
230 2     2 0 11 }
231              
232             sub inject {
233 0     0 0   my ($self, $span, %args) = @_;
234 0   0       $args{format} //= 'text_map';
235 0 0         if($args{format} eq 'text_map') {
236             return {
237 0           map {; $_ => $span->$_ } qw(id trace_id parent_id operation_name start_time finish_time),
  0            
238             }
239             } else {
240             die 'unknown format ' . $args{format}
241 0           }
242             }
243              
244             sub span_for_future {
245 0     0 0   my ($self, $f, %args) = @_;
246 0           my $span = $self->span(
247             operation_name => $f->label,
248             %args,
249             );
250             $f->on_ready(sub {
251 0     0     $span->tag(
252             'future.state' => $f->state
253             );
254 0           $span->finish;
255 0           undef $f;
256 0           undef $span
257 0           });
258 0           return $span;
259             }
260              
261             sub extract {
262 0     0 0   my ($self, $data, %args) = @_;
263 0   0       $args{format} //= 'text_map';
264 0 0         if($args{format} eq 'text_map') {
265 0           @$data{tracer} = $self;
266 0           return OpenTracing::Span->new(%$data);
267             } else {
268             die 'unknown format ' . $args{format}
269 0           }
270             }
271              
272             sub extract_finished_spans {
273 0     0 0   my ($self, $count) = @_;
274 0 0         if(!defined($count)) {
    0          
275 0           $count = 10;
276             } elsif(!$count) {
277 0           $count = @{$self->{finished_spans}};
  0            
278             }
279 0           return splice @{$self->{finished_spans}}, 0, min(0 + @{$self->{finished_spans}}, $count);
  0            
  0            
280             }
281              
282             sub child_of {
283 0     0 0   my ($self, $context) = @_;
284 0 0         die "Can't create a child_of reference without a valid context" unless $context;
285 0           return OpenTracing::Reference->new(
286             ref_type => OpenTracing::Reference::CHILD_OF,
287             context => $context);
288             }
289              
290             sub follows_from {
291 0     0 0   my ($self, $context) = @_;
292 0 0         die "Can't create a follow_from reference without a valid context" unless $context;
293 0           return OpenTracing::Reference->new(
294             ref_type => OpenTracing::Reference::FOLLOWS_FROM,
295             context => $context);
296             }
297              
298             =head2 DESTROY
299              
300             Triggers callbacks when the batch is discarded. Normally used by the transport
301             mechanism to ensure that the batch is sent over to the tracing endpoint.
302              
303             =cut
304              
305             sub DESTROY {
306 0     0     my ($self) = @_;
307 0 0         return if ${^GLOBAL_PHASE} eq 'DESTRUCT';
308             my $on_destroy = delete $self->{on_destroy}
309 0 0         or return;
310 0           $self->$on_destroy;
311 0           return;
312             }
313              
314             1;
315              
316             __END__