Commit | Line | Data |
4c248161 |
1 | package DBIx::Class::Storage::Statistics; |
2 | use strict; |
aaba9524 |
3 | use warnings; |
4c248161 |
4 | |
68b8ba54 |
5 | # DO NOT edit away without talking to riba first, he will just put it back |
6 | # BEGIN pre-Moo2 import block |
7 | BEGIN { |
8 | require warnings; |
9 | my $initial_fatal_bits = (${^WARNING_BITS}||'') & $warnings::DeadBits{all}; |
10 | local $ENV{PERL_STRICTURES_EXTRA} = 0; |
11 | require Moo; Moo->import; |
12 | require Sub::Quote; Sub::Quote->import('quote_sub'); |
13 | ${^WARNING_BITS} &= ( $initial_fatal_bits | ~ $warnings::DeadBits{all} ); |
14 | } |
15 | # END pre-Moo2 import block |
16 | |
17 | extends 'DBIx::Class'; |
9d522a4e |
18 | use DBIx::Class::_Util 'sigwarn_silencer'; |
9c1700e3 |
19 | use namespace::clean; |
3e110410 |
20 | |
4c248161 |
21 | =head1 NAME |
22 | |
23 | DBIx::Class::Storage::Statistics - SQL Statistics |
24 | |
25 | =head1 SYNOPSIS |
26 | |
27 | =head1 DESCRIPTION |
28 | |
29 | This class is called by DBIx::Class::Storage::DBI as a means of collecting |
faaba25f |
30 | statistics on its actions. Using this class alone merely prints the SQL |
4c248161 |
31 | executed, the fact that it completes and begin/end notification for |
32 | transactions. |
33 | |
34 | To really use this class you should subclass it and create your own method |
35 | for collecting the statistics as discussed in L<DBIx::Class::Manual::Cookbook>. |
36 | |
37 | =head1 METHODS |
38 | |
4c248161 |
39 | =head2 new |
40 | |
41 | Returns a new L<DBIx::Class::Storage::Statistics> object. |
42 | |
4c248161 |
43 | =head2 debugfh |
44 | |
45 | Sets or retrieves the filehandle used for trace/debug output. This should |
46 | be an IO::Handle compatible object (only the C<print> method is used). Initially |
47 | should be set to STDERR - although see information on the |
6fe735fa |
48 | L<DBIC_TRACE> environment variable. |
4c248161 |
49 | |
c6fa3170 |
50 | As getter it will lazily open a filehandle for you if one is not already set. |
70f39278 |
51 | |
52 | =cut |
70f39278 |
53 | |
68b8ba54 |
54 | # FIXME - there ought to be a way to fold this into _debugfh itself |
55 | # having the undef re-trigger the builder (or better yet a default |
56 | # which can be folded in as a qsub) |
c6fa3170 |
57 | sub debugfh { |
58 | my $self = shift; |
9901aad7 |
59 | |
68b8ba54 |
60 | return $self->_debugfh(@_) if @_; |
61 | $self->_debugfh || $self->_build_debugfh; |
62 | } |
63 | |
64 | has _debugfh => ( |
65 | is => 'rw', |
66 | lazy => 1, |
67 | trigger => quote_sub( '$_[0]->_defaulted_to_stderr(undef)' ), |
68 | builder => '_build_debugfh', |
69 | ); |
70 | |
71 | sub _build_debugfh { |
72 | my $fh; |
73 | |
74 | my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} || $ENV{DBIC_TRACE}; |
75 | |
76 | if (defined($debug_env) and ($debug_env =~ /=(.+)$/)) { |
77 | open ($fh, '>>', $1) |
78 | or die("Cannot open trace file $1: $!\n"); |
79 | } |
80 | else { |
81 | open ($fh, '>&STDERR') |
82 | or die("Duplication of STDERR for debug output failed (perhaps your STDERR is closed?): $!\n"); |
83 | $_[0]->_defaulted_to_stderr(1); |
70f39278 |
84 | } |
85 | |
68b8ba54 |
86 | $fh; |
c6fa3170 |
87 | } |
88 | |
68b8ba54 |
89 | has [qw(_defaulted_to_stderr silence callback)] => ( |
90 | is => 'rw', |
91 | ); |
92 | |
c6fa3170 |
93 | =head2 print |
94 | |
95 | Prints the specified string to our debugging filehandle. Provided to save our |
96 | methods the worry of how to display the message. |
97 | |
98 | =cut |
99 | sub print { |
100 | my ($self, $msg) = @_; |
101 | |
102 | return if $self->silence; |
103 | |
9d522a4e |
104 | my $fh = $self->debugfh; |
105 | |
106 | # not using 'no warnings' here because all of this can change at runtime |
107 | local $SIG{__WARN__} = sigwarn_silencer(qr/^Wide character in print/) |
108 | if $self->_defaulted_to_stderr; |
109 | |
110 | $fh->printflush($msg); |
70f39278 |
111 | } |
112 | |
dcdf7b2c |
113 | =head2 silence |
114 | |
115 | Turn off all output if set to true. |
116 | |
4c248161 |
117 | =head2 txn_begin |
118 | |
119 | Called when a transaction begins. |
120 | |
121 | =cut |
122 | sub txn_begin { |
04cf5bbf |
123 | my $self = shift; |
d2075431 |
124 | |
b94139c0 |
125 | return if $self->callback; |
126 | |
70f39278 |
127 | $self->print("BEGIN WORK\n"); |
4c248161 |
128 | } |
129 | |
130 | =head2 txn_rollback |
131 | |
132 | Called when a transaction is rolled back. |
133 | |
134 | =cut |
135 | sub txn_rollback { |
04cf5bbf |
136 | my $self = shift; |
d2075431 |
137 | |
b94139c0 |
138 | return if $self->callback; |
139 | |
70f39278 |
140 | $self->print("ROLLBACK\n"); |
4c248161 |
141 | } |
142 | |
143 | =head2 txn_commit |
144 | |
145 | Called when a transaction is committed. |
146 | |
147 | =cut |
148 | sub txn_commit { |
04cf5bbf |
149 | my $self = shift; |
d2075431 |
150 | |
b94139c0 |
151 | return if $self->callback; |
152 | |
70f39278 |
153 | $self->print("COMMIT\n"); |
4c248161 |
154 | } |
155 | |
adb3554a |
156 | =head2 svp_begin |
157 | |
158 | Called when a savepoint is created. |
159 | |
160 | =cut |
161 | sub svp_begin { |
162 | my ($self, $name) = @_; |
163 | |
b94139c0 |
164 | return if $self->callback; |
165 | |
adb3554a |
166 | $self->print("SAVEPOINT $name\n"); |
167 | } |
168 | |
169 | =head2 svp_release |
170 | |
171 | Called when a savepoint is released. |
172 | |
173 | =cut |
8432aeca |
174 | sub svp_release { |
adb3554a |
175 | my ($self, $name) = @_; |
176 | |
b94139c0 |
177 | return if $self->callback; |
178 | |
179 | $self->print("RELEASE SAVEPOINT $name\n"); |
adb3554a |
180 | } |
181 | |
182 | =head2 svp_rollback |
183 | |
184 | Called when rolling back to a savepoint. |
185 | |
186 | =cut |
187 | sub svp_rollback { |
188 | my ($self, $name) = @_; |
189 | |
b94139c0 |
190 | return if $self->callback; |
191 | |
192 | $self->print("ROLLBACK TO SAVEPOINT $name\n"); |
adb3554a |
193 | } |
194 | |
4c248161 |
195 | =head2 query_start |
196 | |
197 | Called before a query is executed. The first argument is the SQL string being |
198 | executed and subsequent arguments are the parameters used for the query. |
199 | |
200 | =cut |
201 | sub query_start { |
04cf5bbf |
202 | my ($self, $string, @bind) = @_; |
68fcff2f |
203 | |
04cf5bbf |
204 | my $message = "$string: ".join(', ', @bind)."\n"; |
4c248161 |
205 | |
04cf5bbf |
206 | if(defined($self->callback)) { |
207 | $string =~ m/^(\w+)/; |
1b7fb46e |
208 | $self->callback->($1, $message); |
04cf5bbf |
209 | return; |
210 | } |
4c248161 |
211 | |
70f39278 |
212 | $self->print($message); |
4c248161 |
213 | } |
214 | |
215 | =head2 query_end |
216 | |
217 | Called when a query finishes executing. Has the same arguments as query_start. |
218 | |
219 | =cut |
220 | sub query_end { |
04cf5bbf |
221 | my ($self, $string) = @_; |
4c248161 |
222 | } |
223 | |
224 | 1; |
225 | |
0c11ad0e |
226 | =head1 AUTHOR AND CONTRIBUTORS |
4c248161 |
227 | |
0c11ad0e |
228 | See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class |
4c248161 |
229 | |
230 | =head1 LICENSE |
231 | |
0c11ad0e |
232 | You may distribute this code under the same terms as Perl itself. |
4c248161 |
233 | |
234 | =cut |