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