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