Author: timbo
Date: Wed Mar 21 06:47:07 2007
New Revision: 9289
Modified:
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/lib/DBI/Gofer/Transport/mod_perl.pm
dbi/trunk/lib/DBI/Util/_accessor.pm
Log:
Implement Gofer::Execute stats and report via Apache::Status
Modified: dbi/trunk/lib/DBI/Gofer/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Execute.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Execute.pm Wed Mar 21 06:47:07 2007
@@ -24,7 +24,7 @@
forced_connect_dsn
default_connect_attributes
forced_connect_attributes
- requests_served_count
+ stats
));
@@ -32,6 +32,7 @@
my ($self, $args) = @_;
$args->{default_connect_attributes} ||= {};
$args->{forced_connect_attributes} ||= {};
+ $args->{stats} ||= {};
return $self->SUPER::new($args);
}
@@ -109,7 +110,8 @@
my ($self, $request) = @_;
# just a quick hack for now
- if (++$self->{request_count} % 1000 == 0) { # XXX config
+ my $stats = $self->{stats};
+ if (++$stats->{requests_served} % 1000 == 0) { # XXX config
# discard CachedKids from time to time
my %drivers = DBI->installed_drivers();
while ( my ($driver, $drh) = each %drivers ) {
@@ -229,12 +231,14 @@
sub execute_dbh_request {
my ($self, $request) = @_;
+ my $stats = $self->{stats};
my $dbh;
my $rv_ref = eval {
$dbh = $self->_connect($request);
my $args = $request->dbh_method_call; # [ 'method_name', @args ]
my $meth = shift @$args;
+ $stats->{dbh_method_calls}->{$meth}++;
my @rv = ($request->dbh_wantarray)
? $dbh->$meth(@$args)
: scalar $dbh->$meth(@$args);
@@ -261,6 +265,7 @@
}
if ($rv_ref and my $lid_args = $request->dbh_last_insert_id_args) {
+ $stats->{dbh_method_calls}->{last_insert_id}++;
my $id = $dbh->last_insert_id( @$lid_args );
$response->last_insert_id( $id );
}
@@ -306,12 +311,14 @@
my $dbh;
my $sth;
my $last_insert_id;
+ my $stats = $self->{stats};
my $rv = eval {
$dbh = $self->_connect($request);
my $args = $request->dbh_method_call; # [ 'method_name', @args ]
my $meth = shift @$args;
+ $stats->{sth_method_calls}->{$meth}++;
$sth = $dbh->$meth(@$args);
my $last = '(sth)'; # a true value (don't try to return actual sth)
@@ -319,11 +326,13 @@
if (my $calls = $request->sth_method_calls) {
for my $meth_call (@$calls) {
my $method = shift @$meth_call;
+ $stats->{sth_method_calls}->{$method}++;
$last = $sth->$method(@$meth_call);
}
}
if (my $lid_args = $request->dbh_last_insert_id_args) {
+ $stats->{sth_method_calls}->{last_insert_id}++;
$last_insert_id = $dbh->last_insert_id( @$lid_args );
}
Modified: dbi/trunk/lib/DBI/Gofer/Transport/mod_perl.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Transport/mod_perl.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Transport/mod_perl.pm Wed Mar 21 06:47:07 2007
@@ -33,16 +33,23 @@
my %executor_configs = ( default => { } );
my %executor_cache;
-
+my %apache_status_menu_items = (
+ DBI_handles => [ 'DBI Handles', \&apache_status_dbi_handles ],
+ DBI_gofer => [ 'DBI Gofer', \&apache_status_dbi_gofer ],
+);
+my $apache_status_class;
if (MP2) {
- if (Apache2::Module::loaded('Apache2::Status')) {
- Apache2::Status->menu_item('DBI_Gofer' => 'DBI Gofer connections',
\&gofer_status_function);
- }
+ $apache_status_class = "Apache2::Status" if
Apache2::Module::loaded('Apache2::Status');
}
elsif ($INC{'Apache.pm'} # is Apache.pm loaded?
and Apache->can('module') # really?
and Apache->module('Apache::Status')) { # Apache::Status too?
- Apache::Status->menu_item('DBI_Gofer' => 'DBI Gofer connections',
\&gofer_status_function);
+ $apache_status_class = "Apache::Status";
+}
+if ($apache_status_class) {
+ while ( my ($url, $menu_item) = each %apache_status_menu_items ) {
+ $apache_status_class->menu_item($url => @$menu_item);
+ }
}
@@ -129,9 +136,10 @@
}
+#
--------------------------------------------------------------------------------
# XXX --- these should be moved into a separate module (Apache::Status::DBI?)
# menu item for Apache::Status
-sub gofer_status_function {
+sub apache_status_dbi_handles {
my($r, $q) = @_;
my @s = ("<pre>",
"<b>DBI $DBI::VERSION - Drivers, Connections and Statements</b><p>\n",
@@ -148,14 +156,14 @@
scalar @children, scalar keys %{$h->{CachedKids}||{}},
$h->{ActiveKids};
@children = sort { ($a->{Name}||"$a") cmp ($b->{Name}||"$b") }
@children;
- push @s, show_dbi_handle($_, 1) for @children;
+ push @s, _apache_status_dbi_handle($_, 1) for @children;
}
push @s, "<hr></pre>";
return [EMAIL PROTECTED];
}
-sub show_dbi_handle {
+sub _apache_status_dbi_handle {
my ($h, $level) = @_;
my $pad = " " x $level;
my $type = $h->{Type};
@@ -205,17 +213,34 @@
if @children;
push @s, "\n";
- push @s, map { show_dbi_handle($_, $level + 1) } @children;
+ push @s, map { _apache_status_dbi_handle($_, $level + 1) } @children;
return @s;
}
+#
--------------------------------------------------------------------------------
+
+
+sub apache_status_dbi_gofer {
+ my($r, $q) = @_;
+ my @s = ("<pre>",
+ "<b>DBI::Gofer::Transport::mod_perl $VERSION</b><p>\n",
+ );
+ require Data::Dumper;
+ local $Data::Dumper::Indent = 1;
+ local $Data::Dumper::Terse = 1;
+ local $Data::Dumper::Useqq = 1;
+ local $Data::Dumper::Sortkeys = 1;
+ local $Data::Dumper::Quotekeys = 0;
+ local $Data::Dumper::Deparse = 0;
+ local $Data::Dumper::Purity = 0;
+ push @s, escape_html( Data::Dumper::Dumper(\%executor_cache) );
+ return [EMAIL PROTECTED];
+}
1;
__END__
-also need a CGI/FastCGI transport
-
=head1 NAME
DBI::Gofer::Transport::mod_perl - DBD::Gofer server-side transport for http
Modified: dbi/trunk/lib/DBI/Util/_accessor.pm
==============================================================================
--- dbi/trunk/lib/DBI/Util/_accessor.pm (original)
+++ dbi/trunk/lib/DBI/Util/_accessor.pm Wed Mar 21 06:47:07 2007
@@ -3,7 +3,7 @@
use Carp;
our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/);
-# heavily cut-down (but compatible) version of Class::Accessor::Fast to avoid
the dependency
+# based (ever more loosly) on Class::Accessor::Fast
sub new {
my($proto, $fields) = @_;
@@ -32,9 +32,14 @@
no strict 'refs';
foreach my $field (@fields) {
my $accessor = $self->$maker($field);
- *{$class."\:\:$field"} = $accessor
+ *{$class."\:\:$field"} = $accessor
unless defined &{$class."\:\:$field"};
}
+ #my $hash_ref = \%{$class."\:\:_accessors_hash};
+ #$hash_ref->{$_}++ for @fields;
+ # XXX also copy down _accessors_hash of base class(es)
+ # so one in this class is complete
+ return;
}
sub make_accessor {
