split connect_info parser out into private _normalize_connect_info
[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/DBIx::Class/;
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 its 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   return if $self->callback;
93
94   $self->print("BEGIN WORK\n");
95 }
96
97 =head2 txn_rollback
98
99 Called when a transaction is rolled back.
100
101 =cut
102 sub txn_rollback {
103   my $self = shift;
104
105   return if $self->callback;
106
107   $self->print("ROLLBACK\n");
108 }
109
110 =head2 txn_commit
111
112 Called when a transaction is committed.
113
114 =cut
115 sub txn_commit {
116   my $self = shift;
117
118   return if $self->callback;
119
120   $self->print("COMMIT\n");
121 }
122
123 =head2 svp_begin
124
125 Called when a savepoint is created.
126
127 =cut
128 sub svp_begin {
129   my ($self, $name) = @_;
130
131   return if $self->callback;
132
133   $self->print("SAVEPOINT $name\n");
134 }
135
136 =head2 svp_release
137
138 Called when a savepoint is released.
139
140 =cut
141 sub svp_release {
142   my ($self, $name) = @_;
143
144   return if $self->callback;
145
146   $self->print("RELEASE SAVEPOINT $name\n");
147 }
148
149 =head2 svp_rollback
150
151 Called when rolling back to a savepoint.
152
153 =cut
154 sub svp_rollback {
155   my ($self, $name) = @_;
156
157   return if $self->callback;
158
159   $self->print("ROLLBACK TO SAVEPOINT $name\n");
160 }
161
162 =head2 query_start
163
164 Called before a query is executed.  The first argument is the SQL string being
165 executed and subsequent arguments are the parameters used for the query.
166
167 =cut
168 sub query_start {
169   my ($self, $string, @bind) = @_;
170
171   my $message = "$string: ".join(', ', @bind)."\n";
172
173   if(defined($self->callback)) {
174     $string =~ m/^(\w+)/;
175     $self->callback->($1, $message);
176     return;
177   }
178
179   $self->print($message);
180 }
181
182 =head2 query_end
183
184 Called when a query finishes executing.  Has the same arguments as query_start.
185
186 =cut
187 sub query_end {
188   my ($self, $string) = @_;
189 }
190
191 1;
192
193 =head1 AUTHORS
194
195 Cory G. Watson <gphat@cpan.org>
196
197 =head1 LICENSE
198
199 You may distribute this code under the same license as Perl itself.
200
201 =cut