note
tye
<p>
Here is some work-in-progress code for profiling Everything's use of the
database. This will let me track what one page load from PerlMonks requires
of the database in terms of a count of SQL statements, number of records
read, and time spent in database requests.
</p><p>
I've currently tested it with loading some pages and found that a typical
page load requires between 200 and 800 SQL statements at PerlMonks and 1
CPU second of web server time. The thread-that-must-not-be-named takes
about 1500 SQL statements (a few more if not done anonymously) and 8 CPU
seconds.
</p><p>
The major sections also read thousands or tens of thousands of records.
I'll be fixing that as soon as I get the below code into production (and
saving the stats to the database) so that I can quantify how much the fix
improves things.
</p><p>
Note that this profiling code adds very little overhead on the web server
(about 4%) and the code to record the stats into the database will only be
updating a few records (per web server daemon process) every 5 minutes (on
a staggered schedule) so the increase to the load on the database will be
even smaller.
</p><p>
Note that more modern versions of DBI explicitly support subclassing so you probably don't have to play a few of the games I did (at least I assume it is just a version mismatch between module and docs that accounts for the documented method of subclassing not working -- the "games" were quite minor so I haven't bothered to investigate further).
</p><p>
And note that my short-cut for inserting code into a bunch of Everything functions is rather tricky because some of these functions are exported (and you have to apply this type of trick before the exporting is done or else the exported function doesn't end up "wrapped").
</p><p>
And note that I don't use SUPER:: at all. It makes assumptions that don't apply because of the way I give all of my methods (no matter what namespace they are in) access to the same utility functions w/o polluting the class namespaces.
</p>
- [tye]
<readmore><code>
### Set up inheritance: ###
use strict;
########################################
package Everything::DBI;
########################################
use vars qw( $VERSION );
BEGIN { $VERSION= 1.000; }
use vars qw( @ISA );
BEGIN { push @ISA, 'DBI'; }
########################################
package Everything::DBI::db;
########################################
use vars qw( @ISA );
BEGIN { push @ISA, 'DBI::db'; }
########################################
package Everything::DBI::st;
########################################
use vars qw( @ISA );
BEGIN { push @ISA, 'DBI::st'; }
### The implementation: ###
########################################
package Everything::DBI::_impl;
########################################
use Time::HiRes qw( gettimeofday );
sub IntervalUS {
my( $a0, $a1, $b0, $b1 )= @_;
( $b0, $b1 )= gettimeofday() unless defined($b1);
return $b1 - $a1 + ( $b0 - $a0 )*1_000_000;
}
sub TotalUS() { "us" }
sub OpCount() { "cnt" }
sub OpDist() { "dist" }
sub CalledFrom() { "from" }
sub Everything::DBI::connect {
my $pkg= shift @_;
my $dbh= $pkg->DBI::connect( @_ );
return $dbh if ! $dbh;
die "Everything::DBI: ref(DBI::connect(...)) eq '",
ref($dbh), "' not 'DBI::db' !\n"
unless 'DBI::db' eq ref($dbh);
bless $dbh, 'Everything::DBI::db';
return $dbh;
}
# Wrap the common Everything methods used to query
# so we can track the source of each query:
for my $meth ( qw(
Everything.pm
Everything::getNode
Everything::getNodeById
Everything::getType
Everything::selectLinks
Everything::setVars
Everything::updateHits
Everything/HTML.pm
Everything::HTML::genContainer
Everything::HTML::htmlcode
Everything/NodeBase.pm
Everything::NodeBase::getNode
Everything::NodeBase::getNodeById
Everything::NodeBase::getNodeWhere
Everything::NodeBase::getRef
Everything::NodeBase::getType
Everything::NodeBase::selectNodeWhere
Everything::NodeBase::sqlSelect
Everything::NodeBase::sqlSelectHashref
Everything::NodeBase::sqlSelectMany
Everything::NodeCache::new
) ) {
if( $meth =~ /\.pm$/ ) {
require $meth;
next;
}
my $orig= \&$meth;
my $new= sub {
my $set= setCaller($meth);
my @ret;
if( wantarray ) {
@ret= &$orig( @_ );
} elsif( ! defined wantarray ) {
&$orig( @_ );
} else {
$ret[0]= &$orig( @_ );
}
clearCaller() if $set;
return wantarray ? @ret : $ret[0];
};
no strict 'refs';
*{$meth}= $new;
}
BEGIN {
open LOG, ">db.log"
or die "Can't write to db.log: $!\n";
my $caller= "";
my %objs;
sub setCaller {
return if $caller;
my( $meth )= shift @_;
my( $pkg, $file, $line )= caller(1);
my( $sub )= ( caller(2) )[3];
$sub ||= "n/a";
$caller= "$sub > $meth\n line $line of $file";
return 1;
}
sub clearCaller {
$caller= "";
}
sub logQuery {
my( $sth, $us, $op, $sql, $res )= @_;
my $stack= "";
#if( ! $caller ) {
# my $depth= 3;
# while( my $sub= (caller(++$depth))[3] ) {
# $stack .= " < $sub";
# }
#}
if( ! $sth || ! ref($sth) ) {
printf LOG "%.3fms %s%s;%s %s:\n\t%s\n",
$us/1000, $op, $res, $stack, $caller, $sql;
} elsif( "DESTROY" eq $op ) {
my $obj= delete $objs{0+$sth};
my $h= $obj->{OpDist()};
my $ops= "";
for my $op ( keys %$h ) {
$ops .= " $h->{$op}:$op";
}
printf LOG "%.3fms %s; %s:\n\t%s\n",
$obj->{TotalUS()}/1000,$ops, $obj->{CalledFrom()}, $sql;
} else {
my $obj= $objs{0+$sth};
if( ! $obj ) {
$objs{0+$sth}= $obj= {};
$obj->{CalledFrom()}= $caller.$stack;
}
$obj->{TotalUS()} += $us;
$obj->{OpCount()}++;
$obj->{OpDist()}{$op}++;
}
}
}
### Database methods wrapper: ###
sub prepare
{
my $meth= shift @_;
my $dbh= shift @_;
my( $sql )= @_;
my @t0= gettimeofday();
my $spec= "DBI::db::" . $meth;
my $sth= $dbh->$spec( @_ );
my $us= IntervalUS( @t0 );
logQuery( $sth, $us, $meth, $sql );
return $sth if ! $sth || ! ref($sth);
if( 'Everything::DBI::st' ne ref($sth) ) {
die "ref(DBI::db::$meth(...)) eq ", ref($sth), " not DBI::st!"
unless 'DBI::st' eq ref($sth);
bless $sth, 'Everything::DBI::st';
}
return $sth;
}
for my $meth ( qw(
prepare
prepare_cached
do
selectall_arrayref
selectall_hashref
selectcol_arrayref
selectrow_array
selectrow_arrayref
selectrow_hashref
) ) {
eval "sub Everything::DBI::db::$meth { prepare( '$meth', \@_ ); } 1"
or die "$@\n";
}
### Statement methods wrapper: ###
sub execute
{
my $meth= shift @_;
my $sth= shift @_;
my @t0= gettimeofday();
my $spec= "DBI::st::" . $meth;
my $res= $sth->$spec( @_ );
my $us= IntervalUS( @t0 );
my( $sql )= $sth->{Statement};
logQuery( $sth, $us, $meth, $sql, $res );
return $res;
}
for my $meth ( qw(
execute
execute_array
fetchrow_array
fetchrow_arrayref
fetchrow_hashref
fetchall_arrayref
fetchall_hashref
DESTROY
) ) {
eval "sub Everything::DBI::st::$meth { execute( '$meth', \@_ ); } 1"
or die "$@\n";
}
1;
</code>
</readmore>
279867
279867