* Removed dead code (sub _RowNumberOver).
[dbsrgits/DBIx-Class-Historic.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/);
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   if(!defined($self->debugfh())) {
60     my $fh;
61     my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
62                   || $ENV{DBIC_TRACE};
63     if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) {
64       $fh = IO::File->new($1, 'w')
65         or die("Cannot open trace file $1");
66     } else {
67       $fh = IO::File->new('>&STDERR')
68         or die('Duplication of STDERR for debug output failed (perhaps your STDERR is closed?)');
69     }
70
71     $fh->autoflush();
72     $self->debugfh($fh);
73   }
74
75   $self->debugfh->print($msg);
76 }
77
78 =head2 txn_begin
79
80 Called when a transaction begins.
81
82 =cut
83 sub txn_begin {
84   my $self = shift;
85
86   $self->print("BEGIN WORK\n");
87 }
88
89 =head2 txn_rollback
90
91 Called when a transaction is rolled back.
92
93 =cut
94 sub txn_rollback {
95   my $self = shift;
96
97   $self->print("ROLLBACK\n");
98 }
99
100 =head2 txn_commit
101
102 Called when a transaction is committed.
103
104 =cut
105 sub txn_commit {
106   my $self = shift;
107
108   $self->print("COMMIT\n");
109 }
110
111 =head2 svp_begin
112
113 Called when a savepoint is created.
114
115 =cut
116 sub svp_begin {
117   my ($self, $name) = @_;
118
119   $self->print("SAVEPOINT $name\n");
120 }
121
122 =head2 svp_release
123
124 Called when a savepoint is released.
125
126 =cut
127 sub svp_release {
128   my ($self, $name) = @_;
129
130  $self->print("RELEASE SAVEPOINT $name\n");
131 }
132
133 =head2 svp_rollback
134
135 Called when rolling back to a savepoint.
136
137 =cut
138 sub svp_rollback {
139   my ($self, $name) = @_;
140
141  $self->print("ROLLBACK TO SAVEPOINT $name\n");
142 }
143
144 =head2 query_start
145
146 Called before a query is executed.  The first argument is the SQL string being
147 executed and subsequent arguments are the parameters used for the query.
148
149 =cut
150 sub query_start {
151   my ($self, $string, @bind) = @_;
152
153   my $message = "$string: ".join(', ', @bind)."\n";
154
155   if(defined($self->callback)) {
156     $string =~ m/^(\w+)/;
157     $self->callback->($1, $message);
158     return;
159   }
160
161   $self->print($message);
162 }
163
164 =head2 query_end
165
166 Called when a query finishes executing.  Has the same arguments as query_start.
167
168 =cut
169 sub query_end {
170   my ($self, $string) = @_;
171 }
172
173 1;
174
175 =head1 AUTHORS
176
177 Cory G. Watson <gphat@cpan.org>
178
179 =head1 LICENSE
180
181 You may distribute this code under the same license as Perl itself.
182
183 =cut