File Coverage

blib/lib/OpenTracing/Integration/DBI.pm
Criterion Covered Total %
statement 60 60 100.0
branch 2 4 50.0
condition 5 11 45.4
subroutine 14 14 100.0
pod 0 2 0.0
total 81 91 89.0


line stmt bran cond sub pod time code
1             package OpenTracing::Integration::DBI;
2             # ABSTRACT: OpenTracing APM support for DBI-based database interaction
3              
4 1     1   214599 use strict;
  1         14  
  1         36  
5 1     1   7 use warnings;
  1         2  
  1         57  
6              
7             our $VERSION = '0.002';
8             our $AUTHORITY = 'cpan:TEAM'; # AUTHORITY
9              
10 1     1   21 no indirect;
  1         4  
  1         10  
11 1     1   75 use utf8;
  1         3  
  1         8  
12              
13             =encoding utf8
14              
15             =head1 NAME
16              
17             OpenTracing::Integration::DBI - support L tracing
18              
19             =head1 SYNOPSIS
20              
21             use OpenTracing::Integration qw(DBI);
22             my $dbh = DBI->connect(...);
23             $dbh->selectall_arrayref(qw{select * from information_schema.tables});
24              
25             =head1 DESCRIPTION
26              
27             See L for more details.
28              
29             =cut
30              
31 1     1   49 use Syntax::Keyword::Try;
  1         2  
  1         10  
32 1     1   604 use Role::Tiny::With;
  1         396  
  1         78  
33 1     1   509 use Class::Method::Modifiers qw(install_modifier);
  1         1829  
  1         93  
34              
35 1     1   489 use OpenTracing::DSL qw(:v1);
  1         1326  
  1         1825  
36              
37             with qw(OpenTracing::Integration);
38              
39             my $loaded;
40              
41             sub type_from_sql {
42 9     9 0 21 my ($class, $sql) = @_;
43 9         48 my ($type) = $sql =~ /\b(insert|select|update|delete|truncate\s+[a-z]+|copy\s+[a-z]+|show|vacuum|alter\s+[a-z]+|create\s+[a-z]+|drop\s+[a-z]+)\b/i;
44 9         25 return $type;
45             }
46              
47             sub load {
48 1     1 0 23 my ($class, $load_deps) = @_;
49 1 50 33     8 return unless $load_deps or DBI->can('connect');
50              
51 1 50       6 unless($loaded++) {
52 1         24 require DBI;
53             install_modifier q{DBI::db}, around => prepare => sub {
54 3     3   105 my ($code, $dbh, $sql, @rest) = @_;
55 3         11 my $type = $class->type_from_sql($sql);
56             return trace {
57 3         1201 my ($span) = @_;
58             try {
59             $span->tag(
60             'component' => 'DBI',
61             'span.kind' => 'client',
62             'db.operation' => 'prepare',
63             'db.statement' => $sql,
64             'db.type' => 'sql',
65             (defined $dbh->{Name} ? ('db.instance' => $dbh->{Name}) : ()),
66             (defined $dbh->{Username} ? ('db.user' => $dbh->{Username}) : ()),
67             );
68             return $dbh->$code($sql, @rest);
69 3         8 } catch {
70             my $err = $@;
71             $span->tag(
72             error => 1,
73             );
74             die $@;
75             }
76 3   50     30 } operation_name => 'sql prepare: ' . ($type // 'unknown');
77 1         15 };
78             install_modifier q{DBI::st}, around => execute => sub {
79 1     1   206 my ($code, $sth, @bind) = @_;
80 1         16 my $sql = $sth->{Statement};
81 1         7 my $type = $class->type_from_sql($sql);
82             return trace {
83 1         95 my ($span) = @_;
84 1         14 my $cursor = $sth->{CursorName};
85 1         8 my $dbh = $sth->{Database};
86             try {
87             $span->tag(
88             'component' => 'DBI',
89             'span.kind' => 'client',
90             'db.operation' => 'execute',
91             'db.statement' => $sql,
92             'db.type' => 'sql',
93             (defined $cursor ? ('db.cursor' => $cursor) : ()),
94             (defined $dbh->{Name} ? ('db.instance' => $dbh->{Name}) : ()),
95             (defined $dbh->{Username} ? ('db.user' => $dbh->{Username}) : ()),
96             );
97             return $sth->$code(@bind);
98 1         4 } catch {
99             my $err = $@;
100             $span->tag(
101             error => 1,
102             );
103             die $@;
104             }
105 1   50     15 } operation_name => 'sql execute: ' . ($type // 'unknown');
106 1         375 };
107             install_modifier q{DBI::db}, around => do => sub {
108 2     2   7905 my ($code, $dbh, $sql, @rest) = @_;
109 2         23 my $type = $class->type_from_sql($sql);
110             return trace {
111 2         233 my ($span) = @_;
112             try {
113             $span->tag(
114             'component' => 'DBI',
115             'span.kind' => 'client',
116             'db.operation' => 'do',
117             'db.statement' => $sql,
118             'db.type' => 'sql',
119             (defined $dbh->{Name} ? ('db.instance' => $dbh->{Name}) : ()),
120             (defined $dbh->{Username} ? ('db.user' => $dbh->{Username}) : ()),
121             );
122             return $dbh->$code($sql, @rest);
123 2         6 } catch {
124             my $err = $@;
125             $span->tag(
126             error => 1,
127             );
128             die $@;
129             }
130 2   50     32 } operation_name => 'sql do: ' . ($type // 'unknown');
131 1         286 };
132 1         305 for my $op (qw(
133             selectall_arrayref
134             selectall_hashref
135             selectall_array
136             selectrow_arrayref
137             selectrow_hashref
138             selectrow_array
139             selectcol_arrayref
140             )) {
141 7         1728 my ($operation) = split /_/, $op;
142              
143             install_modifier q{DBI::db}, around => $op => sub {
144 3     3   917 my ($code, $dbh, $sql, @rest) = @_;
145 3         15 my $type = $class->type_from_sql($sql);
146             return trace {
147 3         184 my ($span) = @_;
148             try {
149             $span->tag(
150             'component' => 'DBI',
151             'span.kind' => 'client',
152             'db.operation' => $operation,
153             'db.statement' => $sql,
154             'db.type' => 'sql',
155             (defined $dbh->{Name} ? ('db.instance' => $dbh->{Name}) : ()),
156             (defined $dbh->{Username} ? ('db.user' => $dbh->{Username}) : ()),
157             );
158             return $dbh->$code($sql, @rest);
159 3         8 } catch {
160             my $err = $@;
161             $span->tag(
162             error => 1,
163             );
164             die $@;
165             }
166 3   50     33 } operation_name => "sql $operation: " . ($type // 'unknown');
167 7         128 };
168             }
169             }
170             }
171              
172             1;
173              
174             __END__