1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
|
package DBIx::Class::Storage::Statistics;
use strict;
use warnings;
use base qw/DBIx::Class/;
use IO::File;
use namespace::clean;
__PACKAGE__->mk_group_accessors(simple => qw/callback _debugfh silence/);
=head1 NAME
DBIx::Class::Storage::Statistics - SQL Statistics
=head1 SYNOPSIS
=head1 DESCRIPTION
This class is called by DBIx::Class::Storage::DBI as a means of collecting
statistics on its actions. Using this class alone merely prints the SQL
executed, the fact that it completes and begin/end notification for
transactions.
To really use this class you should subclass it and create your own method
for collecting the statistics as discussed in L<DBIx::Class::Manual::Cookbook>.
=head1 METHODS
=cut
=head2 new
Returns a new L<DBIx::Class::Storage::Statistics> object.
=cut
sub new {
my $self = {};
bless $self, (ref($_[0]) || $_[0]);
return $self;
}
=head2 debugfh
Sets or retrieves the filehandle used for trace/debug output. This should
be an IO::Handle compatible object (only the C<print> method is used). Initially
should be set to STDERR - although see information on the
L<DBIC_TRACE> environment variable.
As getter it will lazily open a filehandle for you if one is not already set.
=cut
sub debugfh {
my $self = shift;
if (@_) {
$self->_debugfh($_[0]);
} elsif (!defined($self->_debugfh())) {
my $fh;
my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
|| $ENV{DBIC_TRACE};
if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) {
$fh = IO::File->new($1, 'a')
or die("Cannot open trace file $1");
} else {
$fh = IO::File->new('>&STDERR')
or die('Duplication of STDERR for debug output failed (perhaps your STDERR is closed?)');
}
$fh->autoflush();
$self->_debugfh($fh);
}
$self->_debugfh;
}
=head2 print
Prints the specified string to our debugging filehandle. Provided to save our
methods the worry of how to display the message.
=cut
sub print {
my ($self, $msg) = @_;
return if $self->silence;
$self->debugfh->print($msg);
}
=head2 silence
Turn off all output if set to true.
=head2 txn_begin
Called when a transaction begins.
=cut
sub txn_begin {
my $self = shift;
return if $self->callback;
$self->print("BEGIN WORK\n");
}
=head2 txn_rollback
Called when a transaction is rolled back.
=cut
sub txn_rollback {
my $self = shift;
return if $self->callback;
$self->print("ROLLBACK\n");
}
=head2 txn_commit
Called when a transaction is committed.
=cut
sub txn_commit {
my $self = shift;
return if $self->callback;
$self->print("COMMIT\n");
}
=head2 svp_begin
Called when a savepoint is created.
=cut
sub svp_begin {
my ($self, $name) = @_;
return if $self->callback;
$self->print("SAVEPOINT $name\n");
}
=head2 svp_release
Called when a savepoint is released.
=cut
sub svp_release {
my ($self, $name) = @_;
return if $self->callback;
$self->print("RELEASE SAVEPOINT $name\n");
}
=head2 svp_rollback
Called when rolling back to a savepoint.
=cut
sub svp_rollback {
my ($self, $name) = @_;
return if $self->callback;
$self->print("ROLLBACK TO SAVEPOINT $name\n");
}
=head2 query_start
Called before a query is executed. The first argument is the SQL string being
executed and subsequent arguments are the parameters used for the query.
=cut
sub query_start {
my ($self, $string, @bind) = @_;
my $message = "$string: ".join(', ', @bind)."\n";
if(defined($self->callback)) {
$string =~ m/^(\w+)/;
$self->callback->($1, $message);
return;
}
$self->print($message);
}
=head2 query_end
Called when a query finishes executing. Has the same arguments as query_start.
=cut
sub query_end {
my ($self, $string) = @_;
}
1;
=head1 AUTHORS
Cory G. Watson <gphat@cpan.org>
=head1 LICENSE
You may distribute this code under the same license as Perl itself.
=cut
|
