C4/Reports/Guided.pm

   1 package C4::Reports::Guided;
   2
   3 # Copyright 2007 Liblime Ltd
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use Modern::Perl;
  21 use CGI qw ( -utf8 );
  22 use Carp;
  23
  24 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  25 use C4::Context;
  26 use C4::Templates qw/themelanguage/;
  27 use C4::Koha;
  28 use Koha::DateUtils;
  29 use C4::Output;
  30 use XML::Simple;
  31 use XML::Dumper;
  32 use C4::Debug;
  33 # use Smart::Comments;
  34 # use Data::Dumper;
  35 use C4::Log;
  36
  37 use Koha::AuthorisedValues;
  38
  39 BEGIN {
  40     # set the version for version checking
  41     $VERSION = 3.07.00.049;
  42     require Exporter;
  43     @ISA    = qw(Exporter);
  44     @EXPORT = qw(
  45       get_report_types get_report_areas get_report_groups get_columns build_query get_criteria
  46       save_report get_saved_reports execute_query get_saved_report create_compound run_compound
  47       get_column_type get_distinct_values save_dictionary get_from_dictionary
  48       delete_definition delete_report format_results get_sql
  49       nb_rows update_sql
  50       GetReservedAuthorisedValues
  51       GetParametersFromSQL
  52       IsAuthorisedValueValid
  53       ValidateSQLParameters
  54       nb_rows update_sql
  55     );
  56 }
  57
  58 =head1 NAME
  59
  60 C4::Reports::Guided - Module for generating guided reports
  61
  62 =head1 SYNOPSIS
  63
  64   use C4::Reports::Guided;
  65
  66 =head1 DESCRIPTION
  67
  68 =cut
  69
  70 =head1 METHODS
  71
  72 =head2 get_report_areas
  73
  74 This will return a list of all the available report areas
  75
  76 =cut
  77
  78 sub get_area_name_sql_snippet {
  79     my @REPORT_AREA = (
  80         [CIRC => "Circulation"],
  81         [CAT  => "Catalogue"],
  82         [PAT  => "Patrons"],
  83         [ACQ  => "Acquisition"],
  84         [ACC  => "Accounts"],
  85         [SER  => "Serials"],
  86     );
  87
  88     return "CASE report_area " .
  89     join (" ", map "WHEN '$_->[0]' THEN '$_->[1]'", @REPORT_AREA) .
  90     " END AS areaname";
  91 }
  92
  93 sub get_report_areas {
  94
  95     my $report_areas = [ 'CIRC', 'CAT', 'PAT', 'ACQ', 'ACC', 'SER' ];
  96
  97     return $report_areas;
  98 }
  99
 100 sub get_table_areas {
 101     return (
 102     CIRC => [ 'borrowers', 'statistics', 'items', 'biblioitems' ],
 103     CAT  => [ 'items', 'biblioitems', 'biblio' ],
 104     PAT  => ['borrowers'],
 105     ACQ  => [ 'aqorders', 'biblio', 'items' ],
 106     ACC  => [ 'borrowers', 'accountlines' ],
 107     SER  => [ 'serial', 'serialitems', 'subscription', 'subscriptionhistory', 'subscriptionroutinglist', 'biblioitems', 'biblio', 'aqbooksellers' ],
 108     );
 109 }
 110
 111 =head2 get_report_types
 112
 113 This will return a list of all the available report types
 114
 115 =cut
 116
 117 sub get_report_types {
 118     my $dbh = C4::Context->dbh();
 119
 120     # FIXME these should be in the database perhaps
 121     my @reports = ( 'Tabular', 'Summary', 'Matrix' );
 122     my @reports2;
 123     for ( my $i = 0 ; $i < 3 ; $i++ ) {
 124         my %hashrep;
 125         $hashrep{id}   = $i + 1;
 126         $hashrep{name} = $reports[$i];
 127         push @reports2, \%hashrep;
 128     }
 129     return ( \@reports2 );
 130
 131 }
 132
 133 =head2 get_report_groups
 134
 135 This will return a list of all the available report areas with groups
 136
 137 =cut
 138
 139 sub get_report_groups {
 140     my $dbh = C4::Context->dbh();
 141
 142     my $groups = GetAuthorisedValues('REPORT_GROUP');
 143     my $subgroups = GetAuthorisedValues('REPORT_SUBGROUP');
 144
 145     my %groups_with_subgroups = map { $_->{authorised_value} => {
 146                         name => $_->{lib},
 147                         groups => {}
 148                     } } @$groups;
 149     foreach (@$subgroups) {
 150         my $sg = $_->{authorised_value};
 151         my $g = $_->{lib_opac}
 152           or warn( qq{REPORT_SUBGROUP "$sg" without REPORT_GROUP (lib_opac)} ),
 153              next;
 154         my $g_sg = $groups_with_subgroups{$g}
 155           or warn( qq{REPORT_SUBGROUP "$sg" with invalid REPORT_GROUP "$g"} ),
 156              next;
 157         $g_sg->{subgroups}{$sg} = $_->{lib};
 158     }
 159     return \%groups_with_subgroups
 160 }
 161
 162 =head2 get_all_tables
 163
 164 This will return a list of all tables in the database
 165
 166 =cut
 167
 168 sub get_all_tables {
 169     my $dbh   = C4::Context->dbh();
 170     my $query = "SHOW TABLES";
 171     my $sth   = $dbh->prepare($query);
 172     $sth->execute();
 173     my @tables;
 174     while ( my $data = $sth->fetchrow_arrayref() ) {
 175         push @tables, $data->[0];
 176     }
 177     $sth->finish();
 178     return ( \@tables );
 179
 180 }
 181
 182 =head2 get_columns($area)
 183
 184 This will return a list of all columns for a report area
 185
 186 =cut
 187
 188 sub get_columns {
 189
 190     # this calls the internal function _get_columns
 191     my ( $area, $cgi ) = @_;
 192     my %table_areas = get_table_areas;
 193     my $tables = $table_areas{$area}
 194       or die qq{Unsuported report area "$area"};
 195
 196     my @allcolumns;
 197     my $first = 1;
 198     foreach my $table (@$tables) {
 199         my @columns = _get_columns($table,$cgi, $first);
 200         $first = 0;
 201         push @allcolumns, @columns;
 202     }
 203     return ( \@allcolumns );
 204 }
 205
 206 sub _get_columns {
 207     my ($tablename,$cgi, $first) = @_;
 208     my $dbh         = C4::Context->dbh();
 209     my $sth         = $dbh->prepare("show columns from $tablename");
 210     $sth->execute();
 211     my @columns;
 212         my $column_defs = _get_column_defs($cgi);
 213         my %tablehash;
 214         $tablehash{'table'}=$tablename;
 215     $tablehash{'__first__'} = $first;
 216         push @columns, \%tablehash;
 217     while ( my $data = $sth->fetchrow_arrayref() ) {
 218         my %temphash;
 219         $temphash{'name'}        = "$tablename.$data->[0]";
 220         $temphash{'description'} = $column_defs->{"$tablename.$data->[0]"};
 221         push @columns, \%temphash;
 222     }
 223     $sth->finish();
 224     return (@columns);
 225 }
 226
 227 =head2 build_query($columns,$criteria,$orderby,$area)
 228
 229 This will build the sql needed to return the results asked for,
 230 $columns is expected to be of the format tablename.columnname.
 231 This is what get_columns returns.
 232
 233 =cut
 234
 235 sub build_query {
 236     my ( $columns, $criteria, $orderby, $area, $totals, $definition ) = @_;
 237
 238     my %keys = (
 239         CIRC => [ 'statistics.borrowernumber=borrowers.borrowernumber',
 240                   'items.itemnumber = statistics.itemnumber',
 241                   'biblioitems.biblioitemnumber = items.biblioitemnumber' ],
 242         CAT  => [ 'items.biblioitemnumber=biblioitems.biblioitemnumber',
 243                   'biblioitems.biblionumber=biblio.biblionumber' ],
 244         PAT  => [],
 245         ACQ  => [ 'aqorders.biblionumber=biblio.biblionumber',
 246                   'biblio.biblionumber=items.biblionumber' ],
 247         ACC  => ['borrowers.borrowernumber=accountlines.borrowernumber'],
 248         SER  => [ 'serial.serialid=serialitems.serialid', 'serial.subscriptionid=subscription.subscriptionid', 'serial.subscriptionid=subscriptionhistory.subscriptionid', 'serial.subscriptionid=subscriptionroutinglist.subscriptionid', 'biblioitems.biblionumber=serial.biblionumber', 'biblio.biblionumber=biblioitems.biblionumber', 'subscription.aqbooksellerid=aqbooksellers.id'],
 249     );
 250
 251
 252 ### $orderby
 253     my $keys   = $keys{$area};
 254     my %table_areas = get_table_areas;
 255     my $tables = $table_areas{$area};
 256
 257     my $sql =
 258       _build_query( $tables, $columns, $criteria, $keys, $orderby, $totals, $definition );
 259     return ($sql);
 260 }
 261
 262 sub _build_query {
 263     my ( $tables, $columns, $criteria, $keys, $orderby, $totals, $definition) = @_;
 264 ### $orderby
 265     # $keys is an array of joining constraints
 266     my $dbh           = C4::Context->dbh();
 267     my $joinedtables  = join( ',', @$tables );
 268     my $joinedcolumns = join( ',', @$columns );
 269     my $query =
 270       "SELECT $totals $joinedcolumns FROM $tables->[0] ";
 271         for (my $i=1;$i<@$tables;$i++){
 272                 $query .= "LEFT JOIN $tables->[$i] on ($keys->[$i-1]) ";
 273         }
 274
 275     if ($criteria) {
 276                 $criteria =~ s/AND/WHERE/;
 277         $query .= " $criteria";
 278     }
 279         if ($definition){
 280                 my @definitions = split(',',$definition);
 281                 my $deftext;
 282                 foreach my $def (@definitions){
 283                         my $defin=get_from_dictionary('',$def);
 284                         $deftext .=" ".$defin->[0]->{'saved_sql'};
 285                 }
 286                 if ($query =~ /WHERE/i){
 287                         $query .= $deftext;
 288                 }
 289                 else {
 290                         $deftext  =~ s/AND/WHERE/;
 291                         $query .= $deftext;
 292                 }
 293         }
 294     if ($totals) {
 295         my $groupby;
 296         my @totcolumns = split( ',', $totals );
 297         foreach my $total (@totcolumns) {
 298             if ( $total =~ /\((.*)\)/ ) {
 299                 if ( $groupby eq '' ) {
 300                     $groupby = " GROUP BY $1";
 301                 }
 302                 else {
 303                     $groupby .= ",$1";
 304                 }
 305             }
 306         }
 307         $query .= $groupby;
 308     }
 309     if ($orderby) {
 310         $query .= $orderby;
 311     }
 312     return ($query);
 313 }
 314
 315 =head2 get_criteria($area,$cgi);
 316
 317 Returns an arraref to hashrefs suitable for using in a tmpl_loop. With the criteria and available values.
 318
 319 =cut
 320
 321 sub get_criteria {
 322     my ($area,$cgi) = @_;
 323     my $dbh    = C4::Context->dbh();
 324
 325     # have to do someting here to know if its dropdown, free text, date etc
 326     my %criteria = (
 327         CIRC => [ 'statistics.type', 'borrowers.categorycode', 'statistics.branch',
 328                   'biblioitems.publicationyear|date', 'items.dateaccessioned|date' ],
 329         CAT  => [ 'items.itemnumber|textrange', 'items.biblionumber|textrange',
 330                   'items.barcode|textrange', 'biblio.frameworkcode',
 331                   'items.holdingbranch', 'items.homebranch',
 332                   'biblio.datecreated|daterange', 'biblio.timestamp|daterange',
 333                   'items.onloan|daterange', 'items.ccode',
 334                   'items.itemcallnumber|textrange', 'items.itype', 'items.itemlost',
 335                   'items.location' ],
 336         PAT  => [ 'borrowers.branchcode', 'borrowers.categorycode' ],
 337         ACQ  => ['aqorders.datereceived|date'],
 338         ACC  => [ 'borrowers.branchcode', 'borrowers.categorycode' ],
 339         SER  => ['subscription.startdate|date', 'subscription.enddate|date', 'subscription.periodicity', 'subscription.callnumber', 'subscription.location', 'subscription.branchcode'],
 340     );
 341
 342     # Adds itemtypes to criteria, according to the syspref
 343     if ( C4::Context->preference('item-level_itypes') ) {
 344         unshift @{ $criteria{'CIRC'} }, 'items.itype';
 345         unshift @{ $criteria{'CAT'} }, 'items.itype';
 346     } else {
 347         unshift @{ $criteria{'CIRC'} }, 'biblioitems.itemtype';
 348         unshift @{ $criteria{'CAT'} }, 'biblioitems.itemtype';
 349     }
 350
 351
 352     my $crit   = $criteria{$area};
 353     my $column_defs = _get_column_defs($cgi);
 354     my @criteria_array;
 355     foreach my $localcrit (@$crit) {
 356         my ( $value, $type )   = split( /\|/, $localcrit );
 357         my ( $table, $column ) = split( /\./, $value );
 358         if ($type eq 'textrange') {
 359             my %temp;
 360             $temp{'name'}        = $value;
 361             $temp{'from'}        = "from_" . $value;
 362             $temp{'to'}          = "to_" . $value;
 363             $temp{'textrange'}   = 1;
 364             $temp{'description'} = $column_defs->{$value};
 365             push @criteria_array, \%temp;
 366         }
 367         elsif ($type eq 'date') {
 368             my %temp;
 369             $temp{'name'}        = $value;
 370             $temp{'date'}        = 1;
 371             $temp{'description'} = $column_defs->{$value};
 372             push @criteria_array, \%temp;
 373         }
 374         elsif ($type eq 'daterange') {
 375             my %temp;
 376             $temp{'name'}        = $value;
 377             $temp{'from'}        = "from_" . $value;
 378             $temp{'to'}          = "to_" . $value;
 379             $temp{'daterange'}   = 1;
 380             $temp{'description'} = $column_defs->{$value};
 381             push @criteria_array, \%temp;
 382         }
 383         else {
 384             my $query =
 385             "SELECT distinct($column) as availablevalues FROM $table";
 386             my $sth = $dbh->prepare($query);
 387             $sth->execute();
 388             my @values;
 389             # push the runtime choosing option
 390             my $list;
 391             $list='branches' if $column eq 'branchcode' or $column eq 'holdingbranch' or $column eq 'homebranch';
 392             $list='categorycode' if $column eq 'categorycode';
 393             $list='itemtypes' if $column eq 'itype';
 394             $list='ccode' if $column eq 'ccode';
 395             # TODO : improve to let the librarian choose the description at runtime
 396             push @values, {
 397                 availablevalues => "<<$column" . ( $list ? "|$list" : '' ) . ">>",
 398                 display_value   => "<<$column" . ( $list ? "|$list" : '' ) . ">>",
 399             };
 400             while ( my $row = $sth->fetchrow_hashref() ) {
 401                 if ($row->{'availablevalues'} eq '') { $row->{'default'} = 1 }
 402                 else { $row->{display_value} = _get_display_value( $row->{'availablevalues'}, $column ); }
 403                 push @values, $row;
 404             }
 405             $sth->finish();
 406
 407             my %temp;
 408             $temp{'name'}        = $value;
 409             $temp{'description'} = $column_defs->{$value};
 410             $temp{'values'}      = \@values;
 411
 412             push @criteria_array, \%temp;
 413         }
 414     }
 415     return ( \@criteria_array );
 416 }
 417
 418 sub nb_rows {
 419     my $sql = shift or return;
 420     my $sth = C4::Context->dbh->prepare($sql);
 421     $sth->execute();
 422     my $rows = $sth->fetchall_arrayref();
 423     return scalar (@$rows);
 424 }
 425
 426 =head2 execute_query
 427
 428   ($sth, $error) = execute_query($sql, $offset, $limit[, \@sql_params])
 429
 430
 431 This function returns a DBI statement handler from which the caller can
 432 fetch the results of the SQL passed via C<$sql>.
 433
 434 If passed any query other than a SELECT, or if there is a DB error,
 435 C<$errors> is returned, and is a hashref containing the error after this
 436 manner:
 437
 438 C<$error->{'sqlerr'}> contains the offending SQL keyword.
 439 C<$error->{'queryerr'}> contains the native db engine error returned
 440 for the query.
 441
 442 C<$offset>, and C<$limit> are required parameters.
 443
 444 C<\@sql_params> is an optional list of parameter values to paste in.
 445 The caller is responsible for making sure that C<$sql> has placeholders
 446 and that the number placeholders matches the number of parameters.
 447
 448 =cut
 449
 450 # returns $sql, $offset, $limit
 451 # $sql returned will be transformed to:
 452 #  ~ remove any LIMIT clause
 453 #  ~ repace SELECT clause w/ SELECT count(*)
 454
 455 sub select_2_select_count {
 456     # Modify the query passed in to create a count query... (I think this covers all cases -crn)
 457     my ($sql) = strip_limit(shift) or return;
 458     $sql =~ s/\bSELECT\W+(?:\w+\W+){1,}?FROM\b|\bSELECT\W\*\WFROM\b/SELECT count(*) FROM /ig;
 459     return $sql;
 460 }
 461
 462 # This removes the LIMIT from the query so that a custom one can be specified.
 463 # Usage:
 464 #   ($new_sql, $offset, $limit) = strip_limit($sql);
 465 #
 466 # Where:
 467 #   $sql is the query to modify
 468 #   $new_sql is the resulting query
 469 #   $offset is the offset value, if the LIMIT was the two-argument form,
 470 #       0 if it wasn't otherwise given.
 471 #   $limit is the limit value
 472 #
 473 # Notes:
 474 #   * This makes an effort to not break subqueries that have their own
 475 #     LIMIT specified. It does that by only removing a LIMIT if it comes after
 476 #     a WHERE clause (which isn't perfect, but at least should make more cases
 477 #     work - subqueries with a limit in the WHERE will still break.)
 478 #   * If your query doesn't have a WHERE clause then all LIMITs will be
 479 #     removed. This may break some subqueries, but is hopefully rare enough
 480 #     to not be a big issue.
 481 sub strip_limit {
 482     my ($sql) = @_;
 483
 484     return unless $sql;
 485     return ($sql, 0, undef) unless $sql =~ /\bLIMIT\b/i;
 486
 487     # Two options: if there's no WHERE clause in the SQL, we simply capture
 488     # any LIMIT that's there. If there is a WHERE, we make sure that we only
 489     # capture a LIMIT after the last one. This prevents stomping on subqueries.
 490     if ($sql !~ /\bWHERE\b/i) {
 491         (my $res = $sql) =~ s/\bLIMIT\b\s*(\d+)(\s*\,\s*(\d+))?\s*/ /ig;
 492         return ($res, (defined $2 ? $1 : 0), (defined $3 ? $3 : $1));
 493     } else {
 494         my $res = $sql;
 495         $res =~ m/.*\bWHERE\b/gsi;
 496         $res =~ s/\G(.*)\bLIMIT\b\s*(\d+)(\s*\,\s*(\d+))?\s*/$1 /is;
 497         return ($res, (defined $3 ? $2 : 0), (defined $4 ? $4 : $2));
 498     }
 499 }
 500
 501 sub execute_query {
 502
 503     my ( $sql, $offset, $limit, $sql_params ) = @_;
 504
 505     $sql_params = [] unless defined $sql_params;
 506
 507     # check parameters
 508     unless ($sql) {
 509         carp "execute_query() called without SQL argument";
 510         return;
 511     }
 512     $offset = 0    unless $offset;
 513     $limit  = 999999 unless $limit;
 514     $debug and print STDERR "execute_query($sql, $offset, $limit)\n";
 515     if ($sql =~ /;?\W?(UPDATE|DELETE|DROP|INSERT|SHOW|CREATE)\W/i) {
 516         return (undef, {  sqlerr => $1} );
 517     } elsif ($sql !~ /^\s*SELECT\b\s*/i) {
 518         return (undef, { queryerr => 'Missing SELECT'} );
 519     }
 520
 521     my ($useroffset, $userlimit);
 522
 523     # Grab offset/limit from user supplied LIMIT and drop the LIMIT so we can control pagination
 524     ($sql, $useroffset, $userlimit) = strip_limit($sql);
 525     $debug and warn sprintf "User has supplied (OFFSET,) LIMIT = %s, %s",
 526         $useroffset,
 527         (defined($userlimit ) ? $userlimit  : 'UNDEF');
 528     $offset += $useroffset;
 529     if (defined($userlimit)) {
 530         if ($offset + $limit > $userlimit ) {
 531             $limit = $userlimit - $offset;
 532         } elsif ( ! $offset && $limit < $userlimit ) {
 533             $limit = $userlimit;
 534         }
 535     }
 536     $sql .= " LIMIT ?, ?";
 537
 538     my $sth = C4::Context->dbh->prepare($sql);
 539     $sth->execute(@$sql_params, $offset, $limit);
 540     return ( $sth, { queryerr => $sth->errstr } ) if ($sth->err);
 541     return ( $sth );
 542     # my @xmlarray = ... ;
 543     # my $url = "/cgi-bin/koha/reports/guided_reports.pl?phase=retrieve%20results&id=$id";
 544     # my $xml = XML::Dumper->new()->pl2xml( \@xmlarray );
 545     # store_results($id,$xml);
 546 }
 547
 548 =head2 save_report($sql,$name,$type,$notes)
 549
 550 Given some sql and a name this will saved it so that it can reused
 551 Returns id of the newly created report
 552
 553 =cut
 554
 555 sub save_report {
 556     my ($fields) = @_;
 557     my $borrowernumber = $fields->{borrowernumber};
 558     my $sql = $fields->{sql};
 559     my $name = $fields->{name};
 560     my $type = $fields->{type};
 561     my $notes = $fields->{notes};
 562     my $area = $fields->{area};
 563     my $group = $fields->{group};
 564     my $subgroup = $fields->{subgroup};
 565     my $cache_expiry = $fields->{cache_expiry} || 300;
 566     my $public = $fields->{public};
 567
 568     my $dbh = C4::Context->dbh();
 569     $sql =~ s/(\s*\;\s*)$//;    # removes trailing whitespace and /;/
 570     my $query = "INSERT INTO saved_sql (borrowernumber,date_created,last_modified,savedsql,report_name,report_area,report_group,report_subgroup,type,notes,cache_expiry,public)  VALUES (?,now(),now(),?,?,?,?,?,?,?,?,?)";
 571     $dbh->do($query, undef, $borrowernumber, $sql, $name, $area, $group, $subgroup, $type, $notes, $cache_expiry, $public);
 572
 573     my $id = $dbh->selectrow_array("SELECT max(id) FROM saved_sql WHERE borrowernumber=? AND report_name=?", undef,
 574                                    $borrowernumber, $name);
 575     return $id;
 576 }
 577
 578 sub update_sql {
 579     my $id         = shift || croak "No Id given";
 580     my $fields     = shift;
 581     my $sql = $fields->{sql};
 582     my $name = $fields->{name};
 583     my $notes = $fields->{notes};
 584     my $group = $fields->{group};
 585     my $subgroup = $fields->{subgroup};
 586     my $cache_expiry = $fields->{cache_expiry};
 587     my $public = $fields->{public};
 588
 589     if( $cache_expiry >= 2592000 ){
 590       die "Please specify a cache expiry less than 30 days\n";
 591     }
 592
 593     my $dbh        = C4::Context->dbh();
 594     $sql =~ s/(\s*\;\s*)$//;    # removes trailing whitespace and /;/
 595     my $query = "UPDATE saved_sql SET savedsql = ?, last_modified = now(), report_name = ?, report_group = ?, report_subgroup = ?, notes = ?, cache_expiry = ?, public = ? WHERE id = ? ";
 596     $dbh->do($query, undef, $sql, $name, $group, $subgroup, $notes, $cache_expiry, $public, $id );
 597 }
 598
 599 sub store_results {
 600         my ($id,$xml)=@_;
 601         my $dbh = C4::Context->dbh();
 602         my $query = "SELECT * FROM saved_reports WHERE report_id=?";
 603         my $sth = $dbh->prepare($query);
 604         $sth->execute($id);
 605         if (my $data=$sth->fetchrow_hashref()){
 606                 my $query2 = "UPDATE saved_reports SET report=?,date_run=now() WHERE report_id=?";
 607                 my $sth2 = $dbh->prepare($query2);
 608             $sth2->execute($xml,$id);
 609         }
 610         else {
 611                 my $query2 = "INSERT INTO saved_reports (report_id,report,date_run) VALUES (?,?,now())";
 612                 my $sth2 = $dbh->prepare($query2);
 613                 $sth2->execute($id,$xml);
 614         }
 615 }
 616
 617 sub format_results {
 618         my ($id) = @_;
 619         my $dbh = C4::Context->dbh();
 620         my $query = "SELECT * FROM saved_reports WHERE report_id = ?";
 621         my $sth = $dbh->prepare($query);
 622         $sth->execute($id);
 623         my $data = $sth->fetchrow_hashref();
 624         my $dump = new XML::Dumper;
 625         my $perl = $dump->xml2pl( $data->{'report'} );
 626         foreach my $row (@$perl) {
 627                 my $htmlrow="<tr>";
 628                 foreach my $key (keys %$row){
 629                         $htmlrow .= "<td>$row->{$key}</td>";
 630                 }
 631                 $htmlrow .= "</tr>";
 632                 $row->{'row'} = $htmlrow;
 633         }
 634         $sth->finish;
 635         $query = "SELECT * FROM saved_sql WHERE id = ?";
 636         $sth = $dbh->prepare($query);
 637         $sth->execute($id);
 638         $data = $sth->fetchrow_hashref();
 639         return ($perl,$data->{'report_name'},$data->{'notes'});
 640 }
 641
 642 sub delete_report {
 643     my (@ids) = @_;
 644     return unless @ids;
 645     foreach my $id (@ids) {
 646         my $data = get_saved_report($id);
 647         logaction( "REPORTS", "DELETE", $id, "$data->{'report_name'} | $data->{'savedsql'}  " ) if C4::Context->preference("ReportsLog");
 648     }
 649     my $dbh = C4::Context->dbh;
 650     my $query = 'DELETE FROM saved_sql WHERE id IN (' . join( ',', ('?') x @ids ) . ')';
 651     my $sth = $dbh->prepare($query);
 652     return $sth->execute(@ids);
 653 }
 654
 655 sub get_saved_reports_base_query {
 656     my $area_name_sql_snippet = get_area_name_sql_snippet;
 657     return <<EOQ;
 658 SELECT s.*, r.report, r.date_run, $area_name_sql_snippet, av_g.lib AS groupname, av_sg.lib AS subgroupname,
 659 b.firstname AS borrowerfirstname, b.surname AS borrowersurname
 660 FROM saved_sql s
 661 LEFT JOIN saved_reports r ON r.report_id = s.id
 662 LEFT OUTER JOIN authorised_values av_g ON (av_g.category = 'REPORT_GROUP' AND av_g.authorised_value = s.report_group)
 663 LEFT OUTER JOIN authorised_values av_sg ON (av_sg.category = 'REPORT_SUBGROUP' AND av_sg.lib_opac = s.report_group AND av_sg.authorised_value = s.report_subgroup)
 664 LEFT OUTER JOIN borrowers b USING (borrowernumber)
 665 EOQ
 666 }
 667
 668 sub get_saved_reports {
 669 # $filter is either { date => $d, author => $a, keyword => $kw, }
 670 # or $keyword. Optional.
 671     my ($filter) = @_;
 672     $filter = { keyword => $filter } if $filter && !ref( $filter );
 673     my ($group, $subgroup) = @_;
 674
 675     my $dbh   = C4::Context->dbh();
 676     my $query = get_saved_reports_base_query;
 677     my (@cond,@args);
 678     if ($filter) {
 679         if (my $date = $filter->{date}) {
 680             $date = eval { output_pref( { dt => dt_from_string( $date ), dateonly => 1, dateformat => 'iso' }); };
 681             push @cond, "DATE(date_run) = ? OR
 682                          DATE(date_created) = ? OR
 683                          DATE(last_modified) = ? OR
 684                          DATE(last_run) = ?";
 685             push @args, $date, $date, $date, $date;
 686         }
 687         if (my $author = $filter->{author}) {
 688             $author = "%$author%";
 689             push @cond, "surname LIKE ? OR
 690                          firstname LIKE ?";
 691             push @args, $author, $author;
 692         }
 693         if (my $keyword = $filter->{keyword}) {
 694             push @cond, q|
 695                        report LIKE ?
 696                     OR report_name LIKE ?
 697                     OR notes LIKE ?
 698                     OR savedsql LIKE ?
 699                     OR s.id = ?
 700             |;
 701             push @args, "%$keyword%", "%$keyword%", "%$keyword%", "%$keyword%", $keyword;
 702         }
 703         if ($filter->{group}) {
 704             push @cond, "report_group = ?";
 705             push @args, $filter->{group};
 706         }
 707         if ($filter->{subgroup}) {
 708             push @cond, "report_subgroup = ?";
 709             push @args, $filter->{subgroup};
 710         }
 711     }
 712     $query .= " WHERE ".join( " AND ", map "($_)", @cond ) if @cond;
 713     $query .= " ORDER by date_created";
 714
 715     my $result = $dbh->selectall_arrayref($query, {Slice => {}}, @args);
 716
 717     return $result;
 718 }
 719
 720 sub get_saved_report {
 721     my $dbh   = C4::Context->dbh();
 722     my $query;
 723     my $report_arg;
 724     if ($#_ == 0 && ref $_[0] ne 'HASH') {
 725         ($report_arg) = @_;
 726         $query = " SELECT * FROM saved_sql WHERE id = ?";
 727     } elsif (ref $_[0] eq 'HASH') {
 728         my ($selector) = @_;
 729         if ($selector->{name}) {
 730             $query = " SELECT * FROM saved_sql WHERE report_name = ?";
 731             $report_arg = $selector->{name};
 732         } elsif ($selector->{id} || $selector->{id} eq '0') {
 733             $query = " SELECT * FROM saved_sql WHERE id = ?";
 734             $report_arg = $selector->{id};
 735         } else {
 736             return;
 737         }
 738     } else {
 739         return;
 740     }
 741     return $dbh->selectrow_hashref($query, undef, $report_arg);
 742 }
 743
 744 =head2 create_compound($masterID,$subreportID)
 745
 746 This will take 2 reports and create a compound report using both of them
 747
 748 =cut
 749
 750 sub create_compound {
 751     my ( $masterID, $subreportID ) = @_;
 752     my $dbh = C4::Context->dbh();
 753
 754     # get the reports
 755     my $master = get_saved_report($masterID);
 756     my $mastersql = $master->{savedsql};
 757     my $mastertype = $master->{type};
 758     my $sub = get_saved_report($subreportID);
 759     my $subsql = $master->{savedsql};
 760     my $subtype = $master->{type};
 761
 762     # now we have to do some checking to see how these two will fit together
 763     # or if they will
 764     my ( $mastertables, $subtables );
 765     if ( $mastersql =~ / from (.*) where /i ) {
 766         $mastertables = $1;
 767     }
 768     if ( $subsql =~ / from (.*) where /i ) {
 769         $subtables = $1;
 770     }
 771     return ( $mastertables, $subtables );
 772 }
 773
 774 =head2 get_column_type($column)
 775
 776 This takes a column name of the format table.column and will return what type it is
 777 (free text, set values, date)
 778
 779 =cut
 780
 781 sub get_column_type {
 782         my ($tablecolumn) = @_;
 783         my ($table,$column) = split(/\./,$tablecolumn);
 784         my $dbh = C4::Context->dbh();
 785         my $catalog;
 786         my $schema;
 787
 788     # mysql doesn't support a column selection, set column to %
 789         my $tempcolumn='%';
 790         my $sth = $dbh->column_info( $catalog, $schema, $table, $tempcolumn ) || die $dbh->errstr;
 791         while (my $info = $sth->fetchrow_hashref()){
 792                 if ($info->{'COLUMN_NAME'} eq $column){
 793                         #column we want
 794                         if ($info->{'TYPE_NAME'} eq 'CHAR' || $info->{'TYPE_NAME'} eq 'VARCHAR'){
 795                                 $info->{'TYPE_NAME'} = 'distinct';
 796                         }
 797                         return $info->{'TYPE_NAME'};
 798                 }
 799         }
 800 }
 801
 802 =head2 get_distinct_values($column)
 803
 804 Given a column name, return an arrary ref of hashrefs suitable for use as a tmpl_loop
 805 with the distinct values of the column
 806
 807 =cut
 808
 809 sub get_distinct_values {
 810         my ($tablecolumn) = @_;
 811         my ($table,$column) = split(/\./,$tablecolumn);
 812         my $dbh = C4::Context->dbh();
 813         my $query =
 814           "SELECT distinct($column) as availablevalues FROM $table";
 815         my $sth = $dbh->prepare($query);
 816         $sth->execute();
 817     return $sth->fetchall_arrayref({});
 818 }
 819
 820 sub save_dictionary {
 821     my ( $name, $description, $sql, $area ) = @_;
 822     my $dbh   = C4::Context->dbh();
 823     my $query = "INSERT INTO reports_dictionary (name,description,saved_sql,report_area,date_created,date_modified)
 824   VALUES (?,?,?,?,now(),now())";
 825     my $sth = $dbh->prepare($query);
 826     $sth->execute($name,$description,$sql,$area) || return 0;
 827     return 1;
 828 }
 829
 830 sub get_from_dictionary {
 831     my ( $area, $id ) = @_;
 832     my $dbh   = C4::Context->dbh();
 833     my $area_name_sql_snippet = get_area_name_sql_snippet;
 834     my $query = <<EOQ;
 835 SELECT d.*, $area_name_sql_snippet
 836 FROM reports_dictionary d
 837 EOQ
 838
 839     if ($area) {
 840         $query .= " WHERE report_area = ?";
 841     } elsif ($id) {
 842         $query .= " WHERE id = ?";
 843     }
 844     my $sth = $dbh->prepare($query);
 845     if ($id) {
 846         $sth->execute($id);
 847     } elsif ($area) {
 848         $sth->execute($area);
 849     } else {
 850         $sth->execute();
 851     }
 852     my @loop;
 853     while ( my $data = $sth->fetchrow_hashref() ) {
 854         push @loop, $data;
 855     }
 856     return ( \@loop );
 857 }
 858
 859 sub delete_definition {
 860         my ($id) = @_ or return;
 861         my $dbh = C4::Context->dbh();
 862         my $query = "DELETE FROM reports_dictionary WHERE id = ?";
 863         my $sth = $dbh->prepare($query);
 864         $sth->execute($id);
 865 }
 866
 867 sub get_sql {
 868         my ($id) = @_ or return;
 869         my $dbh = C4::Context->dbh();
 870         my $query = "SELECT * FROM saved_sql WHERE id = ?";
 871         my $sth = $dbh->prepare($query);
 872         $sth->execute($id);
 873         my $data=$sth->fetchrow_hashref();
 874         return $data->{'savedsql'};
 875 }
 876
 877 sub _get_column_defs {
 878     my ($cgi) = @_;
 879     my %columns;
 880     my $columns_def_file = "columns.def";
 881     my $htdocs = C4::Context->config('intrahtdocs');
 882     my $section = 'intranet';
 883
 884     # We need the theme and the lang
 885     # Since columns.def is not in the modules directory, we cannot sent it for the $tmpl var
 886     my ($theme, $lang, $availablethemes) = C4::Templates::themelanguage($htdocs, 'about.tt', $section, $cgi);
 887
 888     my $full_path_to_columns_def_file="$htdocs/$theme/$lang/$columns_def_file";
 889     open (my $fh, '<:encoding(utf-8)', $full_path_to_columns_def_file);
 890     while ( my $input = <$fh> ){
 891         chomp $input;
 892         if ( $input =~ m|<field name="(.*)">(.*)</field>| ) {
 893             my ( $field, $translation ) = ( $1, $2 );
 894             $columns{$field} = $translation;
 895         }
 896     }
 897     close $fh;
 898     return \%columns;
 899 }
 900
 901 =head2 GetReservedAuthorisedValues
 902
 903     my %reserved_authorised_values = GetReservedAuthorisedValues();
 904
 905 Returns a hash containig all reserved words
 906
 907 =cut
 908
 909 sub GetReservedAuthorisedValues {
 910     my %reserved_authorised_values =
 911             map { $_ => 1 } ( 'date',
 912                               'branches',
 913                               'itemtypes',
 914                               'cn_source',
 915                               'categorycode',
 916                               'biblio_framework' );
 917
 918    return \%reserved_authorised_values;
 919 }
 920
 921
 922 =head2 IsAuthorisedValueValid
 923
 924     my $is_valid_ath_value = IsAuthorisedValueValid($authorised_value)
 925
 926 Returns 1 if $authorised_value is on the reserved authorised values list or
 927 in the authorised value categories defined in
 928
 929 =cut
 930
 931 sub IsAuthorisedValueValid {
 932
 933     my $authorised_value = shift;
 934     my $reserved_authorised_values = GetReservedAuthorisedValues();
 935
 936     if ( exists $reserved_authorised_values->{$authorised_value} ||
 937          Koha::AuthorisedValues->search({ category => $authorised_value })->count ) {
 938         return 1;
 939     }
 940
 941     return 0;
 942 }
 943
 944 =head2 GetParametersFromSQL
 945
 946     my @sql_parameters = GetParametersFromSQL($sql)
 947
 948 Returns an arrayref of hashes containing the keys name and authval
 949
 950 =cut
 951
 952 sub GetParametersFromSQL {
 953
 954     my $sql = shift ;
 955     my @split = split(/<<|>>/,$sql);
 956     my @sql_parameters = ();
 957
 958     for ( my $i = 0; $i < ($#split/2) ; $i++ ) {
 959         my ($name,$authval) = split(/\|/,$split[$i*2+1]);
 960         push @sql_parameters, { 'name' => $name, 'authval' => $authval };
 961     }
 962
 963     return \@sql_parameters;
 964 }
 965
 966 =head2 ValidateSQLParameters
 967
 968     my @problematic_parameters = ValidateSQLParameters($sql)
 969
 970 Returns an arrayref of hashes containing the keys name and authval of
 971 those SQL parameters that do not correspond to valid authorised names
 972
 973 =cut
 974
 975 sub ValidateSQLParameters {
 976
 977     my $sql = shift;
 978     my @problematic_parameters = ();
 979     my $sql_parameters = GetParametersFromSQL($sql);
 980
 981     foreach my $sql_parameter (@$sql_parameters) {
 982         if ( defined $sql_parameter->{'authval'} ) {
 983             push @problematic_parameters, $sql_parameter unless
 984                 IsAuthorisedValueValid($sql_parameter->{'authval'});
 985         }
 986     }
 987
 988     return \@problematic_parameters;
 989 }
 990
 991 sub _get_display_value {
 992     my ( $original_value, $column ) = @_;
 993     if ( $column eq 'periodicity' ) {
 994         my $dbh = C4::Context->dbh();
 995         my $query = "SELECT description FROM subscription_frequencies WHERE id = ?";
 996         my $sth   = $dbh->prepare($query);
 997         $sth->execute($original_value);
 998         return $sth->fetchrow;
 999     }
1000     return $original_value;
1001 }
1002
1003 1;
1004 __END__
1005
1006 =head1 AUTHOR
1007
1008 Chris Cormack <crc@liblime.com>
1009
1010 =cut