Apache::Status::DBI - Show status of all DBI database and statement handles

NAME

VERSION

SYNOPSIS

    use Apache::Status;
    use Apache::Status::DBI;

DESCRIPTION

CONFIGURATION

DEPENDENCIES

BUGS AND LIMITATIONS

TODO

AUTHOR

LICENCE AND COPYRIGHT

DISCLAIMER OF WARRANTY

package Apache::Status::DBI;

use warnings;
use strict;
use Carp;

our $VERSION = '1.012'; # $Id: DBI.pm 9845 2007-08-16 14:13:30Z timbo $

use DBI ();

# if MOD_PERL_API_VERSION env var exists then use it to determine mod_perl v1 or v2
# if not, then assume mod_perl v2 if we can load mod_perl2 module
use constant MP2 => (exists $ENV{MOD_PERL_API_VERSION})
        ? ($ENV{MOD_PERL_API_VERSION} >= 2)
        : eval { require mod_perl2 };

BEGIN {
    if (MP2) {
        require mod_perl2;
        require Apache2::Module;
        *escape_html = sub {
            my $s = shift;
            $s =~ s/&/&/g;
            $s =~ s/</&lt;/g;
            $s =~ s/>/&gt;/g;
            return $s;
        }
    }
    else {
        require Apache;
        require Apache::Util;
        Apache::Util->import(qw(escape_html));
    }
}

my %apache_status_menu_items = (
    DBI_handles => [ 'DBI Handles', \&apache_status_dbi_handles ],
);
my $apache_status_class;
if (MP2) {
    $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_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);
    }
}

sub apache_status_dbi_handles {
    my($r, $q) = @_;
    my @s = ("<pre>",
        "<b>DBI $DBI::VERSION - Drivers, Connections and Statements</b><p>\n",
    );

    my %drivers = DBI->installed_drivers();
    push @s, sprintf("%d drivers loaded: %s<p>", scalar keys %drivers, join(", ", keys %drivers));
    
    while ( my ($driver, $h) = each %drivers) {
        my $version = do { no strict; ${"DBD::${driver}::VERSION"} || 'undef' }; ## no critic
        my @children = grep { defined } @{$h->{ChildHandles}};
        
        push @s, sprintf "<hr><b>DBD::$driver</b>  <font size=-2 color=grey>version $version,  %d dbh (%d cached, %d active)  $h</font>\n\n",
            scalar @children, scalar keys %{$h->{CachedKids}||{}}, $h->{ActiveKids};
        
        @children = sort { ($a->{Name}||"$a") cmp ($b->{Name}||"$b") } @children;
        push @s, _apache_status_dbi_handle($_, 1) for @children;
    }
    
    push @s, "<hr>";
    push @s, "<font size=-2 color=grey>".__PACKAGE__." $VERSION</font>";
    push @s, "</pre>\n";
    return \@s;
}



sub _apache_status_dbi_handle {
    my ($h, $level) = @_;
    my $pad = "    " x $level;
    my $type = $h->{Type};
    my @children = grep { defined } @{$h->{ChildHandles}};
    my @boolean_attr = qw(
        Active Executed RaiseError PrintError ShowErrorStatement PrintWarn
        CompatMode InactiveDestroy HandleError HandleSetErr
        ChopBlanks LongTruncOk TaintIn TaintOut Profile);
    my @scalar_attr = qw(
        ErrCount TraceLevel FetchHashKeyName LongReadLen
    ); 
    my @scalar_attr2 = qw();

    my @s;
    if ($type eq 'db') {
        push @s, sprintf "DSN \"<b>%s</b>\"  <font size=-2 color=grey>%s</font>\n", $h->{Name}, $h;
        @children = sort { ($a->{Statement}||"$a") cmp ($b->{Statement}||"$b") } @children;
        push @boolean_attr, qw(AutoCommit);
        push @scalar_attr,  qw(Username);
    }
    else {
        push @s, sprintf "    sth  <font size=-2 color=grey>%s</font>\n", $h;
        push @scalar_attr2, qw(NUM_OF_PARAMS NUM_OF_FIELDS CursorName);
    }

    push @s, sprintf "%sAttributes: %s\n", $pad,
        join ", ", grep { $h->{$_} } @boolean_attr;
    push @s, sprintf "%sAttributes: %s\n", $pad,
        join ", ", map { "$_=".DBI::neat($h->{$_}) } @scalar_attr;
    if (my $sql = escape_html($h->{Statement} || '')) {
        $sql =~ s/\n/ /g;
        push @s, sprintf "%sStatement: <b>%s</b>\n", $pad, $sql;
        my $ParamValues = $type eq 'st' && $h->{ParamValues};
        push @s, sprintf "%sParamValues: %s\n", $pad,
                join ", ", map { "$_=".DBI::neat($ParamValues->{$_}) } sort keys %$ParamValues
            if $ParamValues && %$ParamValues;
    }
    push @s, sprintf "%sAttributes: %s\n", $pad,
        join ", ", map { "$_=".DBI::neat($h->{$_}) } @scalar_attr2
        if @scalar_attr2;
    push @s, sprintf "%sRows: %s\n", $pad, $h->rows
        if $type eq 'st' || $h->rows != -1;
    if (defined( my $err = $h->err )) {
        push @s, sprintf "%s%s %s %s\n", $pad,
            ($err ? "Error" : length($err) ? "Warning" : "Information"),
            $err, escape_html($h->errstr);
    }
    push @s, sprintf "    sth: %d (%d cached, %d active)\n",
        scalar @children, scalar keys %{$h->{CachedKids}||{}}, $h->{ActiveKids}
        if @children;
    push @s, "\n";

    push @s, map { _apache_status_dbi_handle($_, $level + 1) } @children;

    return @s;
}


1; # Magic true value required at end of module
__END__