#!/usr/bin/perl # Copyright 2000-2002 Katipo Communications # # This file is part of Koha. # # Koha is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # Koha is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with Koha; if not, see . use Modern::Perl; use CGI qw ( -utf8 ); use C4::Auth qw( get_template_and_user ); use C4::Context; use C4::Koha qw( GetAuthorisedValues ); use C4::Output qw( output_html_with_http_headers ); use C4::Reports qw( GetDelimiterChoices ); use Koha::AuthorisedValues; use Koha::ItemTypes; use Koha::Patron::Attribute::Types; =head1 NAME reports/issues_stats.pl =head1 DESCRIPTION Plugin that shows circulation stats =cut my $input = CGI->new; my $fullreportname = "reports/issues_stats.tt"; my $do_it = $input->param('do_it') ? 1 : 0; my $line_input = $input->param("Line"); my $column_input = $input->param("Column"); my @filters = $input->multi_param("Filter"); my $podsp_input = $input->param("DisplayBy"); my $type_input = $input->param("PeriodTypeSel"); my $daysel_input = $input->param("PeriodDaySel"); my $monthsel_input = $input->param("PeriodMonthSel"); my $calc = 1; my $calc_input = $input->param("Cellvalue"); my $output = "screen"; my $output_input = $input->param("output"); my $basename = "Export"; my $basename_input = $input->param("basename"); my ( $template, $borrowernumber, $cookie ) = get_template_and_user( { template_name => $fullreportname, query => $input, type => "intranet", flagsrequired => { reports => '*' }, } ); my $library_id = C4::Context->userenv ? C4::Context->userenv->{'branch'} : undef; my @attribute_types = Koha::Patron::Attribute::Types->search_with_library_limits( {}, {}, $library_id )->as_list; my %allowed_attribute_codes = map { $_->code => 1 } @attribute_types; my $attribute_filters = {}; my $vars = $input->Vars; for my $key ( keys %$vars ) { next unless index( $key, 'Filter_borrower_attributes.' ) == 0; my $code = substr( $key, length('Filter_borrower_attributes.') ); next unless exists $allowed_attribute_codes{$code}; my $value = $vars->{$key}; $value =~ s/\*/%/g if $value; $attribute_filters->{$code} = $value; } # Allowed values for Line and Column my %allowed_fields = ( "datetime" => 1, "returndate" => 1, "borrowers.categorycode" => 1, "itemtype" => 1, "branch" => 1, "items.ccode" => 1, "items.location" => 1, "borrowers.sort1" => 1, "borrowers.sort2" => 1, "items.homebranch" => 1, "items.holdingbranch" => 1, "borrowers.branchcode" => 1, ); my $line = report_field( $line_input, 'branch', \%allowed_fields, \%allowed_attribute_codes ); my $column = report_field( $column_input, 'datetime', \%allowed_fields, \%allowed_attribute_codes ); # Validate DisplayBy parameter my $podsp = ""; if ( $podsp_input && $podsp_input =~ /^[1-4]$/ ) { $podsp = $podsp_input; } # Validate PeriodTypeSel parameter my %allowed_types = ( "issue" => 1, "onsite_checkout" => 1, "renew" => 1, "return" => 1, "localuse" => 1, ); my $type; if ( $type_input && $allowed_types{$type_input} ) { $type = $type_input; } # Validate PeriodDaySel parameter my %allowed_days = map { $_ => 1 } qw(Monday Tuesday Wednesday Thursday Friday Saturday Sunday); my $daysel; if ( $daysel_input && $allowed_days{$daysel_input} ) { $daysel = $daysel_input; } # Validate PeriodMonthSel parameter my %allowed_months = map { $_ => 1 } qw(January February March April May June July August September October November December); my $monthsel; if ( $monthsel_input && $allowed_months{$monthsel_input} ) { $monthsel = $monthsel_input; } # Validate Cellvalue parameter if ( $calc_input && $calc_input =~ /^\d+$/ ) { $calc = $calc_input; } # Validate output parameter if ( $output_input && ( $output_input eq "screen" || $output_input eq "file" ) ) { $output = $output_input; } # Validate basename parameter if ($basename_input) { $basename_input =~ s/[^A-Za-z0-9-]+/_/g; if ($basename_input) { $basename = $basename_input; } } our $sep = C4::Context->csv_delimiter( scalar $input->param("sep") ); our $itemtypes = Koha::ItemTypes->search_with_localization->unblessed; our @patron_categories = Koha::Patron::Categories->search_with_library_limits( {}, { order_by => ['description'] } )->as_list; our $locations = { map { ( $_->{authorised_value} => $_->{lib} ) } Koha::AuthorisedValues->get_descriptions_by_koha_field( { frameworkcode => '', kohafield => 'items.location' }, { order_by => ['description'] } ) }; our $ccodes = { map { ( $_->{authorised_value} => $_->{lib} ) } Koha::AuthorisedValues->get_descriptions_by_koha_field( { frameworkcode => '', kohafield => 'items.ccode' }, { order_by => ['description'] } ) }; our $Bsort1 = GetAuthorisedValues("Bsort1"); our $Bsort2 = GetAuthorisedValues("Bsort2"); my ( $hassort1, $hassort2 ); $hassort1 = 1 if $Bsort1; $hassort2 = 1 if $Bsort2; $template->param( do_it => $do_it, ); if ($do_it) { # Displaying results my $results = calculate( $line, $column, $podsp, $type, $daysel, $monthsel, $calc, \@filters, $attribute_filters ); if ( $output eq "screen" ) { # Printing results to screen $template->param( mainloop => $results ); output_html_with_http_headers $input, $cookie, $template->output; } else { # Printing to a csv file print $input->header( -type => 'application/vnd.sun.xml.calc', -encoding => 'utf-8', -attachment => "$basename.csv", -filename => "$basename.csv" ); my $cols = @$results[0]->{loopcol}; my $lines = @$results[0]->{looprow}; # header top-right print @$results[0]->{line} . "/" . @$results[0]->{column} . $sep; # Other header foreach my $col (@$cols) { print $col->{coltitle} . $sep; } print "Total\n"; # Table foreach my $line (@$lines) { my $x = $line->{loopcell}; print $line->{rowtitle} . $sep; print map { $_->{value} . $sep } @$x; print $line->{totalrow}, "\n"; } # footer print "TOTAL"; $cols = @$results[0]->{loopfooter}; print map { $sep . $_->{totalcol} } @$cols; print $sep. @$results[0]->{total}; } exit; } my $dbh = C4::Context->dbh; # location list my @locations; foreach ( sort keys %$locations ) { push @locations, { code => $_, description => "$_ - " . $locations->{$_} }; } my @ccodes; foreach ( sort { $ccodes->{$a} cmp $ccodes->{$b} } keys %$ccodes ) { push @ccodes, { code => $_, description => $ccodes->{$_} }; } my $CGIextChoice = ('CSV'); # FIXME translation my $CGIsepChoice = GetDelimiterChoices; my %attribute_types_by_class; for my $attribute_type (@attribute_types) { $attribute_type = $attribute_type->unblessed; if ( $attribute_type->{authorised_value_category} ) { my $authorised_values = C4::Koha::GetAuthorisedValues( $attribute_type->{authorised_value_category} ); foreach my $authorised_value (@$authorised_values) { push @{ $attribute_type->{authorised_values} }, $authorised_value; } } push @{ $attribute_types_by_class{ $attribute_type->{class} } }, $attribute_type; } $template->param( categoryloop => \@patron_categories, itemtypes => $itemtypes, locationloop => \@locations, ccodeloop => \@ccodes, hassort1 => $hassort1, hassort2 => $hassort2, Bsort1 => $Bsort1, Bsort2 => $Bsort2, CGIextChoice => $CGIextChoice, CGIsepChoice => $CGIsepChoice, attribute_types_by_class => \%attribute_types_by_class, ); output_html_with_http_headers $input, $cookie, $template->output; sub calculate { my ( $line, $column, $dsp, $type, $daysel, $monthsel, $process, $filters, $attribute_filters ) = @_; my @loopfooter; my @loopcol; my @loopline; my @looprow; my %globalline; my $grantotal = 0; # extract parameters my $dbh = C4::Context->dbh; my ( $line_attribute_type, $column_attribute_type ); if ( $line =~ /^borrower_attributes\.(.*)/ ) { $line_attribute_type = $1; $line = "borrower_attributes.attribute"; } if ( $column =~ /^borrower_attributes\.(.*)/ ) { $column_attribute_type = $1; $column = "borrower_attributes.attribute"; } # Filters # Checking filters # my @loopfilter; for ( my $i = 0 ; $i <= @$filters ; $i++ ) { my %cell; ( @$filters[$i] ) or next; if ( ( $i == 1 ) and ( @$filters[ $i - 1 ] ) ) { $cell{err} = 1 if ( @$filters[$i] lt @$filters[ $i - 1 ] ); } # format the dates filters, otherwise just fill as is $cell{filter} = @$filters[$i]; $cell{crit} = $i; push @loopfilter, \%cell; } foreach my $type ( keys %$attribute_filters ) { if ( $attribute_filters->{$type} ) { my $patron_attribute_type = Koha::Patron::Attribute::Types->find($type); push @loopfilter, { crit => "PA_CLASS", label => $patron_attribute_type->description, filter => $attribute_filters->{$type} }; } } push @loopfilter, { crit => "Event", filter => $type }; push @loopfilter, { crit => "Display by", filter => $dsp } if ($dsp); push @loopfilter, { crit => "Select Day", filter => $daysel } if ($daysel); push @loopfilter, { crit => "Select Month", filter => $monthsel } if ($monthsel); my @linefilter; my ( $colsource, $linesource ) = ( '', '' ); $linefilter[1] = @$filters[1] if ( $line =~ /datetime/ ); $linefilter[0] = ( $line =~ /datetime/ ) ? @$filters[0] : ( $line =~ /category/ ) ? @$filters[2] : ( $line =~ /itemtype/ ) ? @$filters[3] : ( $line =~ /^branch/ ) ? @$filters[4] : ( $line =~ /ccode/ ) ? @$filters[5] : ( $line =~ /location/ ) ? @$filters[6] : ( $line =~ /sort1/ ) ? @$filters[9] : ( $line =~ /sort2/ ) ? @$filters[10] : ( $line =~ /homebranch/ ) ? @$filters[11] : ( $line =~ /holdingbranch/ ) ? @$filters[12] : ( $line =~ /borrowers.branchcode/ ) ? @$filters[13] : ( defined $line_attribute_type ) ? $attribute_filters->{$line_attribute_type} : undef; if ( $line =~ /ccode/ or $line =~ /location/ or $line =~ /homebranch/ or $line =~ /holdingbranch/ ) { $linesource = 'items'; } my @colfilter; $colfilter[1] = @$filters[1] if ( $column =~ /datetime/ ); $colfilter[0] = ( $column =~ /datetime/ ) ? @$filters[0] : ( $column =~ /category/ ) ? @$filters[2] : ( $column =~ /itemtype/ ) ? @$filters[3] : ( $column =~ /^branch/ ) ? @$filters[4] : ( $column =~ /ccode/ ) ? @$filters[5] : ( $column =~ /location/ ) ? @$filters[6] : ( $column =~ /sort1/ ) ? @$filters[9] : ( $column =~ /sort1/ ) ? @$filters[10] : ( $column =~ /homebranch/ ) ? @$filters[11] : ( $column =~ /holdingbranch/ ) ? @$filters[12] : ( $column =~ /borrowers.branchcode/ ) ? @$filters[13] : ( defined $column_attribute_type ) ? $attribute_filters->{$column_attribute_type} : undef; if ( $column =~ /ccode/ or $column =~ /location/ or $column =~ /homebranch/ or $column =~ /holdingbranch/ ) { $colsource = 'items'; } # 1st, loop rows. my $linefield; if ( $line =~ /datetime/ ) { # by Day, Month, Year or Hour (1,2,3,4 respectively) $linefield = ( $dsp == 1 ) ? " dayname($line)" : ( $dsp == 2 ) ? "monthname($line)" : ( $dsp == 3 ) ? " Year($line)" : ( $dsp == 4 ) ? "extract(hour from $line)" : 'date_format(`datetime`,"%Y-%m-%d")'; # Probably should be left alone or passed through Koha::Dates } else { $linefield = $line; } my $lineorder = ( $linefield =~ /dayname/ ) ? "weekday($line)" : ( $linefield =~ /^month/ ) ? " month($line)" : $linefield; my $strsth; if ( defined $line_attribute_type ) { $strsth = "SELECT attribute FROM borrower_attributes WHERE code = ? "; } else { $strsth = "SELECT distinctrow $linefield FROM statistics "; # get stats on items if ccode or location, otherwise borrowers. $strsth .= ( $linesource eq 'items' ) ? " LEFT JOIN items ON (statistics.itemnumber = items.itemnumber) " : " LEFT JOIN borrowers ON (statistics.borrowernumber = borrowers.borrowernumber) "; $strsth .= " WHERE $line IS NOT NULL "; $strsth .= " AND $line != '' " if $line ne "datetime"; } if ( $line =~ /datetime/ ) { if ( $linefilter[1] and ( $linefilter[0] ) ) { $strsth .= " AND $line between ? AND ? "; } elsif ( $linefilter[1] ) { $strsth .= " AND $line <= ? "; } elsif ( $linefilter[0] ) { $strsth .= " AND $line >= ? "; } $strsth .= " AND type = ? " if $type; $strsth .= " AND dayname(datetime) = ? " if $daysel; $strsth .= " AND monthname(datetime) = ? " if $monthsel; } elsif ( $linefilter[0] ) { $linefilter[0] =~ s/\*/%/g; $strsth .= " AND $line LIKE ? "; } $strsth .= " group by $linefield order by $lineorder "; push @loopfilter, { crit => 'SQL =', sql => 1, filter => $strsth }; my $sth = $dbh->prepare($strsth); my @bind = (); if ( defined $line_attribute_type ) { push @bind, $line_attribute_type; } if ( (@linefilter) and ( $linefilter[0] ) and ( $linefilter[1] ) ) { push @bind, $linefilter[0], $linefilter[1] . " 23:59:59"; } elsif ( $linefilter[1] ) { push @bind, $linefilter[1] . " 23:59:59"; } elsif ( $linefilter[0] ) { push @bind, $linefilter[0]; } if ( $line =~ /datetime/ ) { push @bind, $type if $type; push @bind, $daysel if $daysel; push @bind, $monthsel if $monthsel; } $sth->execute(@bind); my $itemtypes_map = { map { $_->{itemtype} => $_ } @{$itemtypes} }; while ( my ($celvalue) = $sth->fetchrow ) { my %cell = ( rowtitle => $celvalue, totalrow => 0 ) ; # we leave 'rowtitle' as hash key (used when filling the table), and add coltitle_display $cell{rowtitle_display} = ( $line =~ /ccode/ ) ? $ccodes->{$celvalue} : ( $line =~ /location/ ) ? $locations->{$celvalue} : ( $line =~ /itemtype/ ) ? $itemtypes_map->{$celvalue}->{translated_description} : $celvalue; # default fallback if ( $line =~ /sort1/ ) { foreach (@$Bsort1) { ( $celvalue eq $_->{authorised_value} ) or next; $cell{rowtitle_display} = $_->{lib} and last; } } elsif ( $line =~ /sort2/ ) { foreach (@$Bsort2) { ( $celvalue eq $_->{authorised_value} ) or next; $cell{rowtitle_display} = $_->{lib} and last; } } elsif ( $line =~ /category/ ) { foreach my $patron_category (@patron_categories) { ( $celvalue eq $patron_category->categorycode ) or next; $cell{rowtitle_display} = $patron_category->description and last; } } push @loopline, \%cell; } # 2nd, loop cols. my $colfield; my $colorder; if ( $column =~ /datetime/ ) { #Display by Day, Month or Year (1,2,3 respectively) $colfield = ( $dsp == 1 ) ? " dayname($column)" : ( $dsp == 2 ) ? "monthname($column)" : ( $dsp == 3 ) ? " Year($column)" : ( $dsp == 4 ) ? "extract(hour from $column)" : 'date_format(`datetime`,"%Y-%m-%d")'; # Probably should be left alone or passed through Koha::Dates } else { $colfield = $column; } $colorder = ( $colfield =~ /dayname/ ) ? "weekday($column)" : ( $colfield =~ /^month/ ) ? " month($column)" : $colfield; my $strsth2; if ( defined $column_attribute_type ) { $strsth2 = "SELECT attribute FROM borrower_attributes WHERE code = ? "; } else { $strsth2 = "SELECT distinctrow $colfield FROM statistics "; # get stats on items if ccode or location, otherwise borrowers. $strsth2 .= ( $colsource eq 'items' ) ? "LEFT JOIN items ON (statistics.itemnumber = items.itemnumber) " : "LEFT JOIN borrowers ON (statistics.borrowernumber = borrowers.borrowernumber) "; $strsth2 .= " WHERE $column IS NOT NULL"; $strsth2 .= " AND $column != '' " if $column ne "datetime"; } if ( $column =~ /datetime/ ) { if ( ( $colfilter[1] ) and ( $colfilter[0] ) ) { $strsth2 .= " AND $column BETWEEN ? AND ? "; } elsif ( $colfilter[1] ) { $strsth2 .= " AND $column <= ? "; } elsif ( $colfilter[0] ) { $strsth2 .= " AND $column >= ? "; } $strsth2 .= " AND type = ? " if $type; $strsth2 .= " AND dayname(datetime) = ? " if $daysel; $strsth2 .= " AND monthname(datetime) = ? " if $monthsel; } elsif ( $colfilter[0] ) { $colfilter[0] =~ s/\*/%/g; $strsth2 .= " AND $column LIKE ? "; } $strsth2 .= " group by $colfield order by $colorder "; push @loopfilter, { crit => 'SQL =', sql => 1, filter => $strsth2 }; my $sth2 = $dbh->prepare($strsth2); my @bind2 = (); if ( defined $column_attribute_type ) { push @bind2, $column_attribute_type; } if ( (@colfilter) and ( $colfilter[0] ) and ( $colfilter[1] ) ) { push @bind2, $colfilter[0], $colfilter[1] . " 23:59:59"; } elsif ( $colfilter[1] ) { push @bind2, $colfilter[1] . " 23:59:59"; } elsif ( $colfilter[0] ) { push @bind2, $colfilter[0]; } if ( $column =~ /datetime/ ) { push @bind2, $type if $type; push @bind2, $daysel if $daysel; push @bind2, $monthsel if $monthsel; } $sth2->execute(@bind2); while ( my ($celvalue) = $sth2->fetchrow ) { my %cell = ( coltitle => $celvalue ) ; # we leave 'coltitle' as hash key (used when filling the table), and add coltitle_display $cell{coltitle_display} = ( $column =~ /ccode/ ) ? $ccodes->{$celvalue} : ( $column =~ /location/ ) ? $locations->{$celvalue} : ( $column =~ /itemtype/ ) ? $itemtypes_map->{$celvalue}->{translated_description} : $celvalue; # default fallback if ( $column =~ /sort1/ ) { foreach (@$Bsort1) { ( $celvalue eq $_->{authorised_value} ) or next; $cell{coltitle_display} = $_->{lib} and last; } } elsif ( $column =~ /sort2/ ) { foreach (@$Bsort2) { ( $celvalue eq $_->{authorised_value} ) or next; $cell{coltitle_display} = $_->{lib} and last; } } elsif ( $column =~ /category/ ) { foreach my $patron_category (@patron_categories) { ( $celvalue eq $patron_category->categorycode ) or next; $cell{coltitle_display} = $patron_category->description and last; } } push @loopcol, \%cell; } #Initialization of cell values..... my %table; foreach my $row (@loopline) { foreach my $col (@loopcol) { table_set( \%table, $row->{rowtitle}, $col->{coltitle}, 0 ); } table_set( \%table, $row->{rowtitle}, 'totalrow', 0 ); } my %required_attribute_codes = map { $_ => 1 } grep { $attribute_filters->{$_} } keys %$attribute_filters; $required_attribute_codes{$line_attribute_type} = 1 if defined $line_attribute_type; $required_attribute_codes{$column_attribute_type} = 1 if defined $column_attribute_type; my @required_attribute_codes = sort keys %required_attribute_codes; my %attribute_aliases; my $attribute_index = 0; for my $attribute_code (@required_attribute_codes) { $attribute_aliases{$attribute_code} = 'attribute_' . $attribute_index++; } # preparing calculation my $strcalc = "SELECT "; if ( defined $line_attribute_type ) { $strcalc .= "TRIM($attribute_aliases{$line_attribute_type}.attribute) AS line_attribute, "; } else { $strcalc .= "TRIM($linefield), "; } if ( defined $column_attribute_type ) { $strcalc .= "TRIM($attribute_aliases{$column_attribute_type}.attribute) AS column_attribute, "; } else { $strcalc .= "TRIM($colfield), "; } $strcalc .= ( $process == 1 ) ? " COUNT(*) " : ( $process == 2 ) ? "(COUNT(DISTINCT borrowers.borrowernumber))" : ( $process == 3 ) ? "(COUNT(DISTINCT statistics.itemnumber))" : ( $process == 5 ) ? "(COUNT(DISTINCT items.biblionumber))" : ''; if ( $process == 4 ) { my $rqbookcount = $dbh->prepare("SELECT count(*) FROM items"); $rqbookcount->execute; my ($bookcount) = $rqbookcount->fetchrow; $strcalc .= "100*(COUNT(DISTINCT statistics.itemnumber))/ $bookcount "; } $strcalc .= " FROM statistics LEFT JOIN borrowers ON statistics.borrowernumber=borrowers.borrowernumber "; for my $type (@required_attribute_codes) { my $alias = $attribute_aliases{$type}; $strcalc .= " LEFT JOIN borrower_attributes AS $alias ON (statistics.borrowernumber = $alias.borrowernumber AND $alias.code = ?) "; } $strcalc .= "LEFT JOIN (SELECT * FROM items UNION SELECT * FROM deleteditems) items ON statistics.itemnumber=items.itemnumber " if ( $linefield =~ /^items\./ or $colfield =~ /^items\./ or $process == 5 or ( $colsource eq 'items' ) || @$filters[5] || @$filters[6] || @$filters[7] || @$filters[8] || @$filters[9] || @$filters[10] || @$filters[11] || @$filters[12] || @$filters[13] ); $strcalc .= "WHERE 1=1 "; my @bind3 = (); @$filters = map { my $f = $_; defined($f) and $f =~ s/\*/%/g; $f } @$filters; $strcalc .= " AND statistics.datetime >= ?" if ( @$filters[0] ); $strcalc .= " AND statistics.datetime <= ?" if ( @$filters[1] ); $strcalc .= " AND borrowers.categorycode LIKE ?" if ( @$filters[2] ); $strcalc .= " AND statistics.itemtype LIKE ?" if ( @$filters[3] ); $strcalc .= " AND statistics.branch LIKE ?" if ( @$filters[4] ); $strcalc .= " AND items.ccode LIKE ?" if ( @$filters[5] ); $strcalc .= " AND items.location LIKE ?" if ( @$filters[6] ); $strcalc .= " AND items.itemcallnumber >= ?" if ( @$filters[7] ); $strcalc .= " AND items.itemcallnumber < ?" if ( @$filters[8] ); $strcalc .= " AND borrowers.sort1 LIKE ?" if ( @$filters[9] ); $strcalc .= " AND borrowers.sort2 LIKE ?" if ( @$filters[10] ); $strcalc .= " AND items.homebranch LIKE ?" if ( @$filters[11] ); $strcalc .= " AND items.holdingbranch LIKE ?" if ( @$filters[12] ); $strcalc .= " AND borrowers.branchcode LIKE ?" if ( @$filters[13] ); $strcalc .= " AND dayname(datetime) = ?" if ($daysel); $strcalc .= " AND monthname(datetime) = ?" if ($monthsel); $strcalc .= " AND statistics.type = ?" if ($type); for my $type (@required_attribute_codes) { if ( $attribute_filters->{$type} ) { $strcalc .= " AND $attribute_aliases{$type}.attribute LIKE ?"; } } # Build bind array for the main calculation query # First, add the attribute filter codes for the JOINs (in the same order as the JOINs above) for my $type (@required_attribute_codes) { push @bind3, $type; } # Then add the filter values push @bind3, @$filters[0] if ( @$filters[0] ); push @bind3, @$filters[1] . " 23:59:59" if ( @$filters[1] ); push @bind3, @$filters[2] if ( @$filters[2] ); push @bind3, @$filters[3] if ( @$filters[3] ); push @bind3, @$filters[4] if ( @$filters[4] ); push @bind3, @$filters[5] if ( @$filters[5] ); push @bind3, @$filters[6] if ( @$filters[6] ); push @bind3, @$filters[7] if ( @$filters[7] ); push @bind3, @$filters[8] if ( @$filters[8] ); push @bind3, @$filters[9] if ( @$filters[9] ); push @bind3, @$filters[10] if ( @$filters[10] ); push @bind3, @$filters[11] if ( @$filters[11] ); push @bind3, @$filters[12] if ( @$filters[12] ); push @bind3, @$filters[13] if ( @$filters[13] ); push @bind3, $daysel if ($daysel); push @bind3, $monthsel if ($monthsel); push @bind3, $type if ($type); # Add attribute filter values for my $type (@required_attribute_codes) { if ( $attribute_filters->{$type} ) { push @bind3, $attribute_filters->{$type}; } } $strcalc .= " GROUP BY "; if ( defined $line_attribute_type ) { $strcalc .= " line_attribute, "; } else { $strcalc .= " $linefield, "; } if ( defined $column_attribute_type ) { $strcalc .= " column_attribute "; } else { $strcalc .= " $colfield "; } $strcalc .= " ORDER BY "; if ( defined $line_attribute_type ) { $strcalc .= " line_attribute, "; } else { $strcalc .= " $lineorder, "; } if ( defined $column_attribute_type ) { $strcalc .= " column_attribute "; } else { $strcalc .= " $colorder "; } my $dbcalc = $dbh->prepare($strcalc); push @loopfilter, { crit => 'SQL =', sql => 1, filter => $strcalc }; $dbcalc->execute(@bind3); my ( $emptycol, $emptyrow ); while ( my ( $row, $col, $value ) = $dbcalc->fetchrow ) { unless ( defined $col ) { $emptycol = 1; } unless ( defined $row ) { $emptyrow = 1; } table_inc( \%table, $row, $col, $value ); table_inc( \%table, $row, 'totalrow', $value ); $grantotal += $value; } push @loopcol, { coltitle => "NULL", coltitle_display => 'NULL' } if ($emptycol); push @loopline, { rowtitle => "NULL", rowtitle_display => 'NULL' } if ($emptyrow); foreach my $row (@loopline) { my @loopcell; #@loopcol ensures the order for columns is common with column titles # and the number matches the number of columns foreach my $col (@loopcol) { my $value = table_get( \%table, $row->{rowtitle}, $col->{coltitle} ); push @loopcell, { value => $value }; } push @looprow, { 'rowtitle_display' => $row->{rowtitle_display}, 'rowtitle' => $row->{rowtitle}, 'loopcell' => \@loopcell, 'totalrow' => table_get( \%table, $row->{rowtitle}, 'totalrow' ), }; } for my $col (@loopcol) { my $total = 0; foreach my $row (@looprow) { $total += table_get( \%table, $row->{rowtitle}, $col->{coltitle} ) || 0; } push @loopfooter, { 'totalcol' => $total }; } # the header of the table $globalline{loopfilter} = \@loopfilter; # the core of the table $globalline{looprow} = \@looprow; $globalline{loopcol} = \@loopcol; # # the foot (totals by borrower type) $globalline{loopfooter} = \@loopfooter; $globalline{total} = $grantotal; $globalline{line} = defined $line_attribute_type ? $line_attribute_type : $line; $globalline{column} = defined $column_attribute_type ? $column_attribute_type : $column; return [ ( \%globalline ) ]; } sub report_field { my ( $value, $default, $allowed_fields, $allowed_attribute_codes ) = @_; return $value if defined $value && exists $allowed_fields->{$value}; return $default unless defined $value && index( $value, 'borrower_attributes.' ) == 0; my $code = substr( $value, length('borrower_attributes.') ); return exists $allowed_attribute_codes->{$code} ? $value : $default; } sub null_to_zzempty { my $string = shift; if ( !defined($string) or $string eq '' or uc($string) eq 'NULL' ) { return 'zzEMPTY'; } return $string; } sub table_set { my ( $table, $row, $col, $val ) = @_; $row = $row // ''; $col = $col // ''; $table->{ null_to_zzempty($row) }->{ null_to_zzempty($col) } = $val; } sub table_get { my ( $table, $row, $col ) = @_; $row = $row // ''; $col = $col // ''; return $table->{ null_to_zzempty($row) }->{ null_to_zzempty($col) }; } sub table_inc { my ( $table, $row, $col, $inc ) = @_; $row = $row // ''; $col = $col // ''; $table->{ null_to_zzempty($row) }->{ null_to_zzempty($col) } += $inc; } 1;