File Coverage

blib/lib/Apache/Status/DBI.pm

Criterion	Covered	Total	%
statement	18	28	64.2
branch	2	4	50.0
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	26	38	68.4

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/
            $s =~ s/>/>/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);
    }
}


=pod

=over 1

=item B

Displays all handles and associated information via the Apache::Status
webpages in a running httpd mod_perl enabled server.

=back

=cut
sub apache_status_dbi_handles {
    my($r, $q) = @_;
    my @s = ("",
        "DBI $DBI::VERSION - Drivers, Connections and Statements\n",
    );

    my %drivers = DBI->installed_drivers();
    push @s, sprintf("%d drivers loaded: %s", 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 "DBD::$driver  version $version,  %d dbh (%d cached, %d active)  $h\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, "";
    push @s, "".__PACKAGE__." $VERSION";
    push @s, "\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 \"%s\"  %s\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  %s\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: %s\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__