File Coverage

File:local/lib/perl5/Data/Printer/Filter/DB.pm
Coverage:100.0%

linestmtbrancondsubtimecode
1package Data::Printer::Filter::DB;
2
2
2
2
2
3
2
30
use strict;
3
2
2
2
2
4
1
20
use warnings;
4
2
2
2
2
388
106
6
use Data::Printer::Filter;
5
2
2
2
2
5
1
593
use Term::ANSIColor;
6
7filter 'DBI::db', sub {
8    my ($dbh, $p) = @_;
9    my $name = $dbh->{Driver}{Name};
10
11    my $string = "$name Database Handle ("
12               . ($dbh->{Active}
13                  ? colored('connected', 'bright_green')
14                  : colored('disconnected', 'bright_red'))
15               . ') {'
16               ;
17    indent;
18    my %dsn = split( /[;=]/, $dbh->{Name} );
19    foreach my $k (keys %dsn) {
20        $string .= newline . "$k: " . $dsn{$k};
21    }
22    $string .= newline . 'Auto Commit: ' . $dbh->{AutoCommit};
23
24    my $kids = $dbh->{Kids};
25    $string .= newline . 'Statement Handles: ' . $kids;
26    if ($kids > 0) {
27        $string .= ' (' . $dbh->{ActiveKids} . ' active)';
28    }
29
30    if ( defined $dbh->err ) {
31        $string .= newline . 'Error: ' . $dbh->errstr;
32    }
33    $string .= newline . 'Last Statement: '
34            . colored( ($dbh->{Statement} || '-'), 'bright_yellow');
35
36    outdent;
37    $string .= newline . '}';
38    return $string;
39};
40
41filter 'DBI::st', sub {
42    my ($sth, $properties) = @_;
43    my $str = colored( ($sth->{Statement} || '-'), 'bright_yellow');
44
45    if ($sth->{NUM_OF_PARAMS} > 0) {
46        my $values = $sth->{ParamValues};
47        if ($values) {
48            $str .= '  ('
49                 . join(', ',
50                      map {
51                         my $v = $values->{$_};
52                         $v || 'undef';
53                      } 1 .. $sth->{NUM_OF_PARAMS}
54                   )
55                 . ')';
56        }
57        else {
58            $str .= colored('  (bindings unavailable)', 'yellow');
59        }
60    }
61    return $str;
62};
63
64# DBIx::Class filters
65filter '-class' => sub {
66    my ($obj, $properties) = @_;
67
68    if ( $obj->isa('DBIx::Class::Schema') ) {
69        return ref($obj) . ' DBIC Schema with ' . p( $obj->storage->dbh );
70    }
71    elsif ( grep { $obj->isa($_) } qw(DBIx::Class::ResultSet DBIx::Class::ResultSetColumn) ) {
72
73        my $str = colored( ref($obj), $properties->{color}{class} );
74        $str .= ' (' . $obj->result_class . ')'
75          if $obj->can( 'result_class' );
76
77        if (my $query_data = $obj->as_query) {
78          my @query_data = @$$query_data;
79          indent;
80          my $sql = shift @query_data;
81          $str .= ' {'
82               . newline . colored($sql, 'bright_yellow')
83               . newline . join ( newline, map {
84                      $_->[1] . ' (' . $_->[0]{sqlt_datatype} . ')'
85                    } @query_data
86               )
87               ;
88          outdent;
89          $str .= newline . '}';
90        }
91
92        return $str;
93    }
94    else {
95        return;
96    }
97};
98
99
1001;