File Coverage

blib/lib/DBIx/SQLCrosstab.pm

Criterion	Covered	Total	%
statement	126	586	21.5
branch	46	272	16.9
condition	14	62	22.5
subroutine	13	31	41.9
pod	8	14	57.1
total	207	965	21.4

package DBIx::SQLCrosstab;
use strict;
use warnings;
use DBI;
use Data::Dumper;
use Tree::DAG_Node;

our $VERSION = '1.17';
# 07-Jan-2004

require 5.006;

require Exporter;
our @ISA= qw(Exporter);
our @EXPORT=qw();
our @EXPORT_OK=qw();

our $errstr = "";
my $_RaiseError = 0;
my $_PrintError = 0;

my %_xkeywords = (
   dbh                => 1,
   rows               => 1,
   cols               => 1,
   op                 => 1,
   op_col             => 0, # DEPRECATED - KEPT for backward compatibility
   from               => 1,

   add_op             => 0, # DEPRECATED - KEPT for backward compatibility
   records            => 0,
   col_names          => 0,

   where              => 0,
   having             => 0,
   title              => 0,
   remove_if_null     => 0,
   remove_if_zero     => 0,
   row_total          => 0,
   row_sub_total      => 0,
   col_total          => 0,
   col_sub_total      => 0,
   col_exclude        => 0,

   complete_html_page => 0,
   only_html_header   => 0,

   add_colors         => 0,
   text_color         => 0,
   number_color       => 0,
   header_color       => 0,
   footer_color       => 0,
   table_border       => 0,
   table_cellspacing  => 0,
   table_cellpadding  => 0,
   commify            => 0,
   title_in_header    => 0,

   add_real_names     => 0,
   use_real_names     => 0,
   RaiseError         => 0,
   PrintError         => 0,
);

my %_rowkeywords = (
    col         => 1,
    alias       => 0
);

my %_colkeywords = (
    id             => 1,
    from           => 1,
    value          => 0,
    group          => 0,
    exclude_value  => 0,
    where          => 0,
    orderby        => 0,
    col_list       => 0,
);

my $_stub = {
    dbh    => {dsn=>"dbi:ExampleP:test"},
    op     => [ [ 'COUNT' =>  'dummy' ] ],
    from   => 'dummy',
    cols => [ {id  => 'dummy', from => 'dummy'}],
    rows => [ {col => 'dummy'}],
};

my  @_operations = map {qr/^\s*$_\s*$/i}
    (qw(count sum avg std var max min));

sub new {
    my $class = shift;
    my $opt = shift;
    my $self = bless {
        }, $class;
    return seterr("Parameters required in $class constructor")
        unless $opt;
    if (ref $opt eq 'HASH') {
        for (keys %$opt) {
            $self->{ $_} = $opt->{$_};
        }
    }
    elsif ($opt =~/^stub$/i) {
        for (keys %$_stub) {
            $self->{$_} = $_stub->{$_}
        }
    }
    if ($self->_check_allowed) {
        if ($self->{RaiseError}) {
            $_RaiseError = 1;
        }
        return $self->_check_required
    }
    return undef;
}

#
# set_param( cols => [{id => 'mycol', from => 'mytable'}] )
#

sub set_param {
    my $self = shift;
    while (@_) {
        return seterr("odd number of parameters in set_param")
            unless 2 <= scalar(@_) ;
        my $param = shift;
        my $value = shift;
        if (exists $_xkeywords{$param}) {
            $self->{$param} = $value;
        }
        else {
            return seterr("unrecognized parameter $param ");
        }
    }
    return $self->_check_required;
}

sub op_list{
    my $self = shift;
    return join ",", map { uc( $_->[0]) ."($_->[1])" } @{$self->{op}};
}

sub op {
    my $self = shift;
    return join ",", map { uc $_->[0] } @{$self->{op}};
}

sub op_col {
    my $self = shift;
    return join ",", map { $_->[1] } @{$self->{op}};
}

sub get_params {
    my $self = shift;
    my $params_name = "params";
    my %params =();
    for (keys %_xkeywords) {
        next if /^dbh$/;
        if (exists $self->{$_} and defined($self->{$_})) {
            $params{$_} = $self->{$_};
        }
    }
    local $Data::Dumper::Indent = 1;
    return Data::Dumper->Dump([\%params],[$params_name]);
}

sub save_params {
    my $self = shift;
    my $param_file_name = shift || "xtab_params.pl";
    open PARAMS, "> $param_file_name"
        or return seterr("can't open $param_file_name");
    print PARAMS $self->get_params();
    close(PARAMS) or return seterr("can't close $param_file_name");
    return 1;
}

sub load_params {
    my $self = shift;
    my $params_file_name = shift;
    my $params = undef;
    return seterr("filename required to load_params()")
        unless $params_file_name;
    open PARAMS, "< $params_file_name"
        or return seterr("can't open $params_file_name");
    $errstr = undef;
    {
        local $/;
        my $value = ;
        if ($value) {
            eval $value;
            if ($@) {
                seterr("error retrieving parameters from $params_file_name");
            }
            seterr("no params found in $params_file_name")
                unless $params;
        }
        else {
            seterr("no params found in $params_file_name")
        }
    }
    close(PARAMS) or return seterr("can't close $params_file_name");
    return undef if $errstr;
    return seterr("invalid parameters in $params_file_name")
        unless ref($params) eq 'HASH';
    for (keys %$params) {
        return seterr("unrecognized option ($_) in file $params_file_name")
            unless exists $_xkeywords{$_};
        $self->{$_} = $params->{$_};
    }
    return $self->_check_required;
}

sub seterr {
    my $msg = shift || "-- no msg --";
    $errstr = $msg ;
    if ($_RaiseError) {
        die "$msg\n ";
    }
    elsif ($_PrintError) {
        warn "$msg\n";
    }
    return undef;
}

sub _check_allowed{
    my $self = shift;
    $_RaiseError = (exists($self->{RaiseError}) && $self->{RaiseError} )  ;
    $_PrintError = (exists($self->{PrintError}) && $self->{PrintError});
    for (keys %$self) {
        return seterr("unrecognized option '$_'")
            unless defined $_xkeywords{$_} ;
    }
    if ($self->{col_exclude}) {
        return seterr ("list required with parameter 'col_exclude'")
            unless ref $self->{col_exclude} eq 'ARRAY';
    }
    return $self;
}

sub _check_required_kw {
    my ($set, $kw, $opt) = @_;
    for (grep {$kw->{$_}} keys %$kw)
    {
        return seterr("required $opt '$_' not defined")
            unless defined $set->{$_}
    }
    return $set;
}

sub _check_required {
    my $self = shift;
    for (grep {$_xkeywords{$_}} keys %_xkeywords) {
        return seterr("required option '$_' not defined")
            unless defined $self->{$_};
    }
    if (defined $self->{dbh}) {
        if ( ref($self->{dbh})
            && ( (ref $self->{dbh}) =~ 'DBI::db' ))
        {
            # OK
        }
        elsif (ref($self->{dbh})
              && ( ref( $self->{dbh}) eq "HASH"))
        {
            my $par = $self->{dbh};
            my $dbh;
            eval {$dbh = DBI->connect($par->{dsn},
                    $par->{user}, $par->{password},
                    $par->{params}) or die "$DBI::errstr"
                };
            if ($@) {
                return seterr("error in connection $@")
            }
            else {
                $self->{dbh} = $dbh;
            }
        }
        else
        {
            return seterr("invalid \$dbh parameter")
        }
    }
    else {
        return seterr("\$dbh parameter required")
    }
    for my $row (@{$self->{rows}}) {
        for (grep {$_rowkeywords{$_}} keys %_rowkeywords) {
            return seterr(
                    "missing required parameter ($_) in row definition")
                unless exists $row->{$_}
                && defined $row->{$_}
        }
        for (keys %$row) {
            return seterr("unrecognized row parameter ($_)")
                unless exists $_rowkeywords{$_};
        }
    }
    for my $col (@{$self->{cols}}) {
        for (grep {$_colkeywords{$_}} keys %_colkeywords) {
            return seterr(
                    "missing required parameter ($_) in column definition")
                unless exists $col->{$_}
                && defined $col->{$_}
        }
        for (keys %$col) {
            return seterr("unrecognized row parameter ($_)")
                unless exists $_colkeywords{$_};
        }
    }
    my $op_allowed = 0;

    unless ( ref($self->{op}) )
    # compatibility code for {op}
    {
        my $tmpop;
        return seterr("Parameter 'op_col' undefined")
            unless defined $self->{op_col};
        push @$tmpop, [ $self->{op}, $self->{op_col}];
        if ($self->{add_op}) {
            return seterr("Parameter 'add_op' must be an array reference")
                unless (ref($self->{add_op})
                       && (ref($self->{add_op}) eq 'ARRAY'));
            for my $aop(@{$self->{add_op}}) {
                push @$tmpop, [$aop, $self->{op_col}];
            }
            delete $self->{add_op};
        }
        delete $self->{op_col};
        $self->{op} = $tmpop;
    }

    return seterr("Parameter 'op' must be an array reference")
        unless ref($self->{op}) eq 'ARRAY';
    for my $op (@{$self->{op}}) {
        return
        seterr("All items in parameter {op} must be array references")
            unless (ref($op) && (ref($op) eq 'ARRAY'));
        for my $item (@_operations) {
           return seterr("unrecognized operator $op->[0]")
               unless grep { $op->[0] =~ $_ } @_operations;
           return seterr("Invalid opertator definition (@{$op})")
               unless @$op eq 2;
        }
        if (scalar @{$self->{op}} > 1) {
            $self->{col_total} = 0;
        }
    }

    #for my $op (@_operations) {
    #    if ($self->{op} =~ $op ) {
    #        $op_allowed =1;
    #        last;
    #    }
    #}
    #return seterr("operation not allowed (" . $self->{op} . ")")
    #    unless $op_allowed;
    #if ($self->{add_op}) {
    #    if (ref $self->{add_op} eq 'ARRAY') {
    #        my %seen =();
    #        my @ops = grep {
    #                ($_ ne $self->{op})
    #                and (not $seen{$_}++) } @{$self->{add_op}};
    #        if (@ops) {
    #            $self->{col_total} = 0;
    #            $self->{add_op} = \@ops;
    #        }
    #        else {
    #            $self->{add_op} = undef;
    #        }
    #    }
    #    elsif (lc($self->{add_op}) eq lc($self->{op}))
    #    {
    #        $self->{add_op} = undef;
    #    }
    #    else {
    #        $self->{col_total} = 0;
    #    }
    #}
    if ($self->{add_real_names} and $self->{use_real_names}) {
        $self->{add_real_names} = 0;
    }
    return $self;
}

# _permute function written by Randal L. Schwartz,
# aka merlyn
# http://www.perlmonks.org/index.pl?node_id=24270
#
sub _permute {
   my $last = pop @_;
   unless (@_) {
     return map [$_], @$last;
   }
   return map { my $left = $_; map [@$left, $_], @$last } _permute(@_);
 }

# _permute_group is not permuting anything, actually,
# since the data coming from the distinct query
# is already a permutation. The only task performed here
# is returning the appropriate structure.
sub _permute_group {
    my $array = shift;
    my @permutations;
    for my $row (@$array) {
        push @permutations, [map { {xcol_id => $_, xcol_alias=> $_} } @$row ];
    }
    return \@permutations;
}

# _add_values fills the tree to create
# the appropriate permutations
#
sub _add_values {
    my ($top, $array, $level) = @_;
    return if $level > $#$array;
    my $values = $array->[$level];
    $top->new_daughter
        ->attributes( {contents => $_} ) for @$values;
    _add_values($_, $array, $level+1) for $top->daughters;
}

# _add_group_values fills the tree without
# permutations, which were already found
# in the DISTINCT query
#
sub _add_group_values {
    my ($tr, $array) = @_;
    for my $row (@$array) {
        my $top = $tr;
        for my $col(@$row) {
            my $node = undef;
            if ($top->daughters) {
                ($node) = grep {$_->name eq $col} $top->daughters;
            }
            unless ($node) {
                $node = Tree::DAG_Node->new;
                $node->name($col);
                $node->attributes( {contents => {
                                        xcol_id => $col, xcol_alias=>$col
                                        }} );
                $top->add_daughter($node)
            }
            $top = $node;
        }
    }
}

#
# _xpermute creates a permutation tree
#
sub _xpermute {
    my $array = shift;
    my $mode = shift || "normal";
    my $tree = Tree::DAG_Node->new;
    $tree->name('xtab');
    if ($mode eq "normal") {
        _add_values($tree, $array, 0);
    }
    elsif ($mode eq "group") {
        _add_group_values ($tree,$array)
    }
    else {
        return seterr("unrecognized tree-filling mode ($mode)");
    }
    #print map {"$_\n"} @{$tree->draw_ascii_tree}; exit;
    my @permuted;
    $tree->walk_down (
        {
        callbackback => sub {
            my $node = shift;
            return 1 unless $node->ancestors;
            push @permuted,
                [
                    reverse
                    map {$_->attributes->{contents}}
                    grep {$_->address ne '0'}
                    $node, $node->ancestors
                ];
                1;
            }
        }
    );
    $tree->delete_tree;
    return \@permuted;
}

sub from {
    my $self = shift;
    my $val = shift;
    if ($val) {
        $self->{from} = $val;
        $self->rows($self->{rows});
    }
    return $self->{from};
}

sub rows {
    my $self = shift;
    my $val = shift;
    if ($val) {
        $self->{rows} = $val;
        $self->{query} = "";
        $self->{recs} = undef;
        $self->columns($self->{cols});
    }
    return $self->{rows};
}

sub columns {
    my $self = shift;
    my $val = shift;
    if ($val) {
        $self->{cols} = $val;
        $self->{xvalues} = undef;
    }
    return $self->{cols};
}

# _check_query_separator_applicability checks
# if the query separator is present in any of the
# column values, changing the separator if
# necessary
#
sub _check_query_separator_applicability {
    my $self = shift;
    my $permutations =shift;
    my $separator = shift;
    my %words =();
    for my $row (@{$self->{rows}}) {
        for (qw(id alias value)) {
            if (exists $row->{$_}) {
                $words{$row->{$_}}++;
            }
        }
    }
    for my $p (@$permutations) {
        $words{$_}++ for @$p;
    }
    if ($separator =~ /[a-z?*+]/i) {
        $separator ='#';
    }
    my @separators = ( '#', '/', '-', '=', ',');
    unless (grep {$_ eq $separator} @separators) {
        unshift @separators, $separator;
    }
    my $ok = 0;
    my $count =0;
    while (! $ok) {
        SEPARATOR:
        for my $sep (@separators) {
            $ok =1;
            for my $k (keys %words) {
                if ($k =~ /\Q$sep\E/) {
                    $ok =0;
                    next SEPARATOR;
                }
            }
            if ($ok) {
                $separator = $sep;
                last;
            }
        }
        if (! $ok) {
            @separators = map {$_ . substr($_,0,1) } @separators;
            if ($count++ > 3 ) {
                return seterr("unable to find a suitable column separator char");
            }
        }
    }
    return $separator;
}

#
# gets the values for the column headers
#
sub _get_xvalues {
    my $self = shift;
    my $dbh = $self->{dbh};

    my @xvalues;
    $self->{xvalues} =  undef;
    #
    # group values required
    # columns are evaluated in a unique query
    # rather than separately
    #
    if (grep {exists $_->{group}}  @{$self->{cols}})
    {
        my $colquery = qq{SELECT DISTINCT };
        my $fieldlist = "";

        $fieldlist = join ", ", map {
                $_->{id} . (exists $_->{alias}? " AS $_->{alias}" : "") }
                @{$self->{cols}};
        $colquery .= "$fieldlist\n";
        my ($from) = map {$_->{from}}
                grep {$_->{from} and  ($_->{from} ne "1") }
                @{$self->{cols}};
        $from =~ s/^\s*from//i;
        $colquery .= qq{ FROM $from\n};
        my ($orderby) = map {$_->{orderby}}
                grep {$_->{orderby} }
                @{$self->{cols}};
        if ($orderby) {
            $orderby =~ s/^\s*order by//i;
            $colquery .= qq{ ORDER BY $orderby\n}
        }
        my $sth;
        my $colrecs;
        #print $colquery,$/;
        eval {
            $sth = $dbh->prepare($colquery);
            $sth->execute;
        };
        if ($@) {
            return seterr("Error building group column query ($@)");
        }
        eval {
            $colrecs = $sth->fetchall_arrayref;
        };
        if ($@) {
            return seterr("Error retrieving group column records ($@)");
        }
        $self->{colrecs} = $colrecs;
        for my $r (@$colrecs) {
            my $count =0;
            for my $c (@$r) {
                push @{$xvalues[$count++]}, { xcol_id => $_ , xcol_alias => $_};
            }
        }
        $self->{use_group} = 1;
    }
    else
    # column values
    # are retrieved separately
    # and stored in a bi-dimensional array
    #
    {
      for (@{$self->{cols}}) {
        my $xvals;
        my $xcol_alias = exists $_->{alias} ? $_->{alias} : "xcol_alias";
        #
        # if a list of values is provided
        # then no query is issued, but the values are
        # simply stored in the array
        #
        if ($_->{col_list}) {
            my $list = $_->{col_list};
            unless (ref $list eq 'ARRAY') {
                return seterr("list of values expected in parameter 'col_list'");
            }
            for my $val (@$list) {
                return seterr("elements in {col_list} must be hash references")
                    unless (ref $val eq 'HASH');
                return seterr("elements in {col_list} must have an {id} key")
                    unless (defined $val->{id} );
                unless (defined $val->{value}) {
                    $val->{value} = $val->{id};
                }
                push @$xvals, {xcol_id=> $val->{id}, $xcol_alias => $val->{value} };
            }
        }
        else
        # normal operation
        # The values are retrieved from the database
        # with a query
        {
            my $fields = qq[$_->{id} AS xcol_id];
            if (exists $_->{value}) {
                $fields .= qq[, $_->{value} AS $xcol_alias] ;
            }
            my $colquery = qq[SELECT DISTINCT $fields FROM $_->{from}];
            if (exists $_->{where} ) {
                $_->{where} =~ s/^\s*where\b//i;
                $colquery .= " WHERE ". $_->{where} ." ";
            }
            if (exists $_->{orderby} ) {
                $_->{orderby} =~ s/^\s*order\s+by\b//i;
                $colquery .= " ORDER BY ". $_->{orderby} ." ";
            }
            my $sth;
            eval {
                $sth = $dbh->prepare($colquery);
                $sth->execute;
            };
            if ($@) {
                return seterr
                "error while retrieving column values for $_->{id}\n"
                . qq(query: "$colquery"\n)
                . "error: $DBI::errstr\n";
            }
            eval { $xvals = $sth->fetchall_arrayref({}) };
            if ($@) {
                return seterr("Error while fetching column values "
                        ."($DBI::errstr)");
            }
            unless (exists $_->{value}) {
                for my $row (@$xvals) {
                    $row->{$xcol_alias} = $row->{xcol_id};
                }
            }
        }
        #
        # remove values if required
        #
        if ($_->{exclude_value}) {
            unless  (ref $_->{exclude_value} eq 'ARRAY') {
                return seterr(
                  "list of value expected in parameter"
                  . " '\$cols->{exclude_value}'");
            }
            my @copy_xvals;
            my %exclude_value = map {$_, 1} @{$_->{exclude_value}};
            @copy_xvals = grep {
                    not (exists ($exclude_value{$_->{xcol_id}})
                         or exists ($exclude_value{ $_->{$xcol_alias} }) )
                    } @$xvals;
            $xvals = \@copy_xvals;
        }
        push @xvalues, $xvals;
        my $label = exists $_->{value} ? $_->{value} : $_->{id};
        push @{$self->{xvalues}}, { label => $label, value => $xvals};
        }
    }
    return \@xvalues;
}

sub get_query {
    my $self = shift;
    my $separator = shift || '#';
    return undef unless $self->_check_required;
    my $dbh = $self->{dbh};

    my $xvalues = $self->_get_xvalues
        or return undef; # seterr is already called with the real reason

    for my $row ( @{$self->{rows}} ) {
        $row->{alias} = $row->{col} unless $row->{alias}
    }
    my $xrows = join ", ",
        map { "$_->{col} AS $_->{alias}" }
            @{$self->{rows}};

    my $query = qq{SELECT $xrows \n};

    my @xcols;

    my @permutations;
    if ($self->{use_group}) {
        if ( $self->{col_sub_total}) {
            @permutations = @{_xpermute($self->{colrecs}, "group")};
        }
        else {
            @permutations = @{_permute_group( $self->{colrecs} ) };
        }
    }
    elsif ($self->{col_sub_total}) {
        @permutations = @{_xpermute($xvalues)};
    }
    else {
        @permutations = _permute(@$xvalues);
    }
    #for (@permutations) { print "@$_\n"; } exit;
    $self->{query_separator} =
        $self->_check_query_separator_applicability(\@permutations, $separator)
                or return undef;

    my %realnames =();
    my $col_count ="xfld001";

    for my $op_pair (@{$self->{op}})
    {
        my ($operator, $opcolumn) = @$op_pair;
        for my $val (@permutations)
        {
            my @cn = @{$self->{cols}};
            my $condition = join " AND ",
                map {
                    "$cn[$_]->{id} = "
                    . ($dbh->quote($val->[$_]->{xcol_id}))
                    ." "
                    }
                    (0 .. $#$val);
            my $name = join $self->{query_separator},
                map {$val->[$_]->{xcol_alias}}
                    (0..$#$val);
            next if ($self->{col_exclude} and
                    ( grep {$name eq $_} @{$self->{col_exclude}} ));
            if ($self->{check_group} and $self->{keepcols}) {
                next unless grep { $name =~ /^$_/ } @{$self->{keepcols}};
            }
            #
            # name manipulation
            #
            if (@{$self->{op}} > 1 ) {
                $name = "x" . lc($operator)
                    . $self->{query_separator} . $name ;
            }
            if ($self->{use_real_names}) {
                $name = $dbh->quote($name);
            }
            else {
                $realnames{$col_count} = $name;
                $name = $col_count;
                $col_count++;
            }
            #
            #
            #
            my $line =
                qq[,$operator(CASE WHEN $condition THEN ]
                .qq[ $opcolumn ELSE NULL END) AS $name ] ;
            if ($self->{add_real_names} )
            {
                $line .= qq[ -- ($realnames{$name}) \n];
            }
            else {
                $line .= "\n";
            }

            push @xcols, $line;
        }
        if ((@{$self->{op}} > 1) and $self->{col_sub_total})
        {
            my $opname = "x".lc($operator);
            my $line = qq[,$operator($opcolumn) AS $opname\n];
            push @xcols, $line;
        }
    }
    if (@{$self->{op}} > 1) {
        unshift @{$self->{cols}},  { id => 'op', value=>'op',
            col_list => [map {"x". lc($_->[0])} @{$self->{op}} ] }
    }
    $self->{realnames} = \%realnames;

    $self->{from} =~ s/^\s*from\b//i;
    if ($self->{where}) {
       $self->{where}  =~ s/^\s*where\b//i;
    }
    if ($self->{having}) {
       $self->{having}  =~ s/^\s*having\b//i;
    }

    $query .= $_ for @xcols;
    my $total1 = 'total';
    if ($self->{col_total}) {
        my ($operator, $opcolumn) = @{$self->{op}->[0]};
        $query .= qq[,$operator($opcolumn) AS $total1\n];
    }
    $query .= qq[ FROM $self->{from}\n ];
    if ($self->{where}) {
        $query.= " WHERE ". $self->{where} . " \n";
    }
    $query .= qq[GROUP BY ]
              . join(", ", map {$_->{alias}} @{$self->{rows}})
              . "\n";

    if ($self->{having}) {
        $query.= " HAVING ". $self->{having} . " \n";
    }

    my $numrows = @{$self->{rows}} -1;
    my $nr = $numrows;
    if ($self->{row_sub_total}) {
        for my $row (0..$numrows -1) {
            $xrows = join ", ",
                map {
                    my $val = $self->{rows}->[$_]->{col};
                    $val ="'zzzz'" if $_ >= $nr;
                    "$val AS $self->{rows}->[$_]->{alias}"
                    }
                    (0..$numrows);
            $nr--;
            $query .= qq{UNION\n SELECT $xrows \n};
            $query .= $_ for @xcols;
            if ($self->{col_total} ) {
                my ($operator, $opcolumn) = @{$self->{op}->[0]};
                $query .= qq[,$operator($opcolumn) AS $total1\n];
            }
            $query .= qq[ FROM $self->{from}\n ];
            $xrows = join ", ",
                    map {
                        $self->{rows}->[$_]->{alias}
                        }
                        (0 .. $nr);

            if ($self->{where}) {
                $query.= " WHERE ". $self->{where} . " \n";
            }
            $query .= qq{GROUP BY $xrows\n};
            if ($self->{having}) {
                $query.= " HAVING ". $self->{having} . " \n";
            }
        }
    }

    if ($self->{row_total}) {
        $xrows = join ", ",
                map {"'zzzz' AS $self->{rows}->[$_]->{alias}" }
                    (0..$numrows);
        $query .= qq{UNION\n SELECT $xrows\n};
        $query .= $_ for @xcols;
        if ($self->{col_total}) {
            my ($operator, $opcolumn) = @{$self->{op}->[0]};
            $query .= qq[,$operator($opcolumn) AS $total1\n];
        }
        $query .= qq[ FROM $self->{from}\n ];

        if ($self->{where}) {
            $query.= " WHERE ". $self->{where} . " \n";
        }
    }

    $xrows = join ", ",
         map { $self->{rows}->[$_]->{alias} } (0..$numrows);
    $query .= qq[ORDER BY $xrows\n];
    $query =~ s/ +/ /g;
    $query =~ s/\n\s*\n/\n/sg;
    $query =~ s/^ +//g;
    $self->{query} = $query;
    return $query;
}

sub _max {
    my $max = 0;
    for (@_) {
        $max = $_ if $_ > $max;
    }
    return $max;
}

sub get_recs {
    my $self = shift;
    if ($self->{records} && $self->{col_names}) {
        return seterr("Parameter 'col_names' must be an array reference")
            unless (ref($self->{col_names}) eq 'ARRAY');
        return seterr("Parameter 'records' must be an array reference")
            unless (ref($self->{records}) eq 'ARRAY')
                    and (ref($self->{records}->[0]) eq 'ARRAY');
        $self->{query} = qq{SELECT 'DUMMY'};
        $self->{recs} = $self->{records};
        $self->{NAME} = $self->{col_names};
        $self->{query_separator} = '#';
        return $self->{recs};
    }
    return seterr("call to get_recs() without get_query()")
        unless $self->{query};
    my $sth;
    local $self->{dbh}->{RaiseError} = 1;
    local $self->{dbh}->{PrintError} = 0;
    eval {
        $sth = $self->{dbh}->prepare($self->{query});
    };
    if ($@) {
        return
            seterr "error preparing Crosstab query ($DBI::errstr)\n";
    }
    eval {
        $sth->execute;
    };
    if ($@) {
        return
            seterr "error executing Crosstab query ($DBI::errstr)\n";
    }

    my @fnames = map {exists $self->{realnames}{$_} ?
            $self->{realnames}{$_} : $_ } @{$sth->{NAME}};
    my @lengths =  map {
            my @L =  map {length $_ } split $self->{query_separator}, $_;
            _max( @L)
            } @fnames;

    my $numfields = $sth->{NUM_OF_FIELDS};

    my $recs;
    eval {$recs = $sth->fetchall_arrayref()};
    if ($@) {
        return seterr ("error fetching records ($DBI::errstr)")
    }
    if($self->{remove_if_zero}) {
        my @zeroes = map {defined $_? 0 : 1 } @{$recs->[0]} ;
        for my $r (@$recs) {
            my $count =0;
            for my $c (@$r) {
                if (defined( $c) && ($c ne "0")) {
                    $zeroes[$count] = 1;
                }
                $count++;
            }
        }
        my @voids;
        my @filled;
        for (0..$#zeroes){
            if ( $zeroes[$_] )
            {
                push @filled, $_
            }
            else {
                push @voids, $_
            }
        }
        if (@voids) {
            @fnames = @fnames[@filled];
            $numfields -= @voids;
            for my $rec (@$recs) {
                $rec = [@$rec[@filled]];
            }
            @lengths = @lengths[@filled];
        }
    }

    if($self->{remove_if_null}) {
        my @nulls = map {0} @{$recs->[0]} ;
        for my $r (@$recs) {
            my $count =0;
            for (@$r) {
                if (defined $_) {
                    $nulls[$count] = 1;
                }
                $count++;
            }
        }
        my @voids;
        my @filled;
        for (0..$#nulls){
            if ( $nulls[$_] )
            {
                push @filled, $_
            }
            else {
                push @voids, $_
            }
        }
        if (@voids) {
            @fnames = @fnames[@filled];
            $numfields -= @voids;
            for my $rec (@$recs) {
                $rec = [@$rec[@filled]];
            }
            @lengths = @lengths[@filled];
        }
    }

    for (my $i = 0 ; $i < $numfields; $i++) {
        for (@$recs) {
            my $len = $_->[$i] ? (length($_->[$i])) : 0;
            if (defined($_->[$i]) && $_->[$i] =~ /^\d+\.(\d+)/)
            {
                if (length($1) > 2) {
                    $len -= (length($1) - 2);
                }
            }
            $lengths[$i] = 0 unless defined $lengths[$i];
            $len = 0 unless defined $len;
            $lengths[$i] = $len
                if $lengths[$i] < $len;
        }
    }
    $self->{recs} = $recs;
    $self->{NAME} = \@fnames;
    $self->{LENGTH} = \@lengths;
    $self->{NUM_OF_FIELDS} = $numfields;
    return $recs;
}
1;

__END__