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
|
package CGI::Application::Plugin::DBIProfile::Driver;
use strict;
use IO::Scalar;
=head1 NAME
CGI::Application::Plugin::DBIProfile::Driver - driver module
=head1 TODO: POD
=cut
use vars qw($VERSION $DEBUG @ISA);
$DEBUG = 0;
$VERSION = "1.1";
@ISA = qw(DBI::ProfileDumper);
# TODO: requires DBI 1.49 for class method call interface.
# TODO: requires DBI 1.24 for DBI->{Profile} support, period.
use Carp qw(carp croak);
use DBI;
use DBI::ProfileDumper;
# Override flush_to_disk() to use IO::Scalar rather than a real file.
# Also, change it to return the current formatted dataset, rather
# than write anything out.
# NOTE: the name doesn't fit. Could change that.
sub flush_to_disk
{
my $self = _get_dbiprofile_obj(shift);
return unless defined $self;
my $output = $self->get_current_stats();
$self->empty();
return $output;
}
# This does what flush_to_disk does, without emptying data afterwards.
sub get_current_stats
{
my $self = _get_dbiprofile_obj(shift);
return unless defined $self;
my $data = $self->{Data};
my $output;
my $fh = new IO::Scalar \$output;
$self->write_header($fh);
$self->write_data($fh, $self->{Data}, 1);
close($fh) or croak("Unable to close scalar filehandle: $!");
return $output;
}
# Override on_destroy() to simply clear the data, and close the IO::Scalar.
sub on_destroy
{
shift->empty();
}
# Override empty to it'll behave has a class method.
sub empty
{
my $self = _get_dbiprofile_obj(shift);
return unless defined $self;
$self->SUPER::empty;
}
# utility method to get a usable DBI::Profile object.
sub _get_dbiprofile_obj
{
my $self = shift;
# if we're called by an instance var, just return it.
return $self if ref $self and UNIVERSAL::isa($self, 'DBI::Profile');
# XXX: I couldn't find an instance where I needed to look at more
# than one database handle, even with multiple database handles
# talking to separate dbs using separate drivers.
# I'm not sure how this works out under mod_perl2 using the
# multi-threaded apache service (is there a separate perl memory/name
# space for each thread, or one per process?)
# We may need to loop over handles, fetch data && clear data && merge.
# if we're called as a class method, we need to find at least one
# db handle to work with, and snag its profile.
my $dbh = (_get_all_dbh_handles())[0];
unless (ref $dbh && UNIVERSAL::isa($dbh, 'DBI::db'))
{
carp "Unable to locate active dbh." if $DEBUG;
return;
}
$self = $dbh->{Profile};
if (! ref $self) {
carp "Handle lacks Profile support";
return;
}
return $self;
}
# utility methods to enumerate all database handles
sub _get_all_dbh_handles
{
return grep { $_->{Type} eq 'db' } _get_all_dbi_handles();
}
sub _get_all_dbi_handles
{
my @handles;
my %drivers = DBI->installed_drivers();
push(@handles, _get_all_dbi_child_handles($_) ) for values %drivers;
return @handles;
}
sub _get_all_dbi_child_handles
{
my $h = shift;
my @h = ($h);
push(@h, _get_all_dbi_child_handles($_))
for (grep { defined } @{$h->{ChildHandles}});
return @h;
}
1;
|
