File Coverage

lib/CGI/OptimalQuery/Base.pm

Criterion	Covered	Total	%
statement	33	283	11.6
branch	0	126	0.0
condition	0	54	0.0
subroutine	11	46	23.9
pod	0	34	0.0
total	44	543	8.1

package CGI::OptimalQuery::Base;

use strict;
use warnings;
no warnings qw( uninitialized redefine );

use CGI();
use Carp('confess');
use POSIX();
use DBIx::OptimalQuery;
use JSON::XS;

# some tools that OQ auto activates
use CGI::OptimalQuery::ExportDataTool();
use CGI::OptimalQuery::SaveSearchTool();
use CGI::OptimalQuery::LoadSearchTool();

sub escapeHTML {
  local ($_) = @_;
  s{&}{&}gso;
  s{<}{<}gso;
  s{>}{>}gso;
  s{"}{"}gso;
  s{'}{'}gso;
  s{\x8b}{‹}gso;
  s{\x9b}{›}gso;
  return $_;
}

sub can_embed { 0 }

# alias for output
sub print {
  my $o = shift;
  $o->output(@_);
}

sub new {
  my $pack = shift;
  my $schema = shift;
  die "could not find schema!" unless ref($schema) eq 'HASH';

  my $o = bless {}, $pack;

  $$o{schema} = clone($schema);

  $$o{dbh} = $$o{schema}{dbh}
    or confess "couldn't find dbh in schema!";
  $$o{q} = $$o{schema}{q}
    or confess "couldn't find q in schema!";
  $$o{output_handler} = $$o{schema}{output_handler};
  $$o{error_handler} = $$o{schema}{error_handler};
  $$o{httpHeader} = $$o{schema}{httpHeader};

  # check for required attributes
  confess "specified select is not a hash ref!"
    unless ref $$o{schema}{select} eq "HASH";
  confess "specified joins is not a hash ref!"
    unless ref $$o{schema}{joins} eq "HASH";

  # set defaults
  $$o{schema}{debug} ||= 0;
  $$o{schema}{check} = $ENV{'CGI-OPTIMALQUERY_CHECK'}
    if ! defined $$o{schema}{check};
  $$o{schema}{check} = 0 if ! defined $$o{schema}{check};
  $$o{schema}{title} ||= "";
  $$o{schema}{options} ||= {};
  $$o{schema}{resourceURI} ||= $ENV{OPTIMALQUERY_RESOURCES} || '/OptimalQuery';

  if (! $$o{schema}{URI}) {
    $_ = ($$o{q}->can('uri')) ? $$o{q}->uri() : $ENV{REQUEST_URI}; s/\?.*$//;
    $$o{schema}{URI} = $_;
    # disabled so we can run from command line for testing where REQUEST_URI probably isn't defined
    # or die "could not find 'URI' in schema";
  }

  $$o{schema}{URI_standalone} ||= $$o{schema}{URI};

  # make sure developer is not using illegal state_params
  if (ref($$o{schema}{state_params}) eq 'ARRAY') {
    foreach my $p (@{ $$o{schema}{state_params} }) {
      die "cannot use reserved state param name: act" if $p eq 'act';
      die "cannot use reserved state param name: module" if $p eq 'module';
      die "cannot use reserved state param name: view" if $p eq 'view';
    }
  }

  # construct optimal query object
  $$o{oq} = DBIx::OptimalQuery->new(
    'dbh'           => $$o{schema}{dbh},
    'select'        => $$o{schema}{select},
    'joins'         => $$o{schema}{joins},
    'named_filters' => $$o{schema}{named_filters},
    'named_sorts'   => $$o{schema}{named_sorts},
    'debug'         => $$o{schema}{debug},
    'error_handler' => $$o{schema}{error_handler}
  );

  # the following code is responsible for setting the disable_sort flag for all
  # multi valued selects (since it never makes since to sort a m-valued column)
  my %cached_dep_multival_status;
  my $find_dep_multival_status_i;
  my $find_dep_multival_status;
  $find_dep_multival_status = sub {
    my $joinAlias = shift;
    $find_dep_multival_status_i++;
    die "could not resolve join alias: $joinAlias deps" if $find_dep_multival_status_i > 100;
    if (! exists $cached_dep_multival_status{$joinAlias}) {
      my $v;
      if (exists $$o{oq}{joins}{$joinAlias}[3]{new_cursor}) { $v = 0; }
      elsif (! @{ $$o{oq}{joins}{$joinAlias}[0] }) { $v = 1; }
      else { $v = $find_dep_multival_status->($$o{oq}{joins}{$joinAlias}[0][0]); }
      $cached_dep_multival_status{$joinAlias} = $v;
    }
    return $cached_dep_multival_status{$joinAlias};
  };

  # loop though all selects
  foreach my $selectAlias (keys %{ $$o{oq}{select} }) {
    $find_dep_multival_status_i = 0;

    # set the disable sort flag is select is a multi value
    $$o{oq}{select}{$selectAlias}[3]{disable_sort} = 1
      if ! $find_dep_multival_status->($$o{oq}{select}{$selectAlias}[0][0]);

    # set is_hidden flag if select does not have a nice name assigned
    $$o{oq}{select}{$selectAlias}[3]{is_hidden} = 1
      if ! $$o{oq}{select}{$selectAlias}[2];

    # if no SQL (could be a recview) then disable sort, filter
    if (! $$o{oq}{select}{$selectAlias}[1]) {
      $$o{oq}{select}{$selectAlias}[3]{disable_sort} = 1;
      $$o{oq}{select}{$selectAlias}[3]{disable_filter} = 1;
    }

    # if a select column has additional select fields specified in options, make sure that the options array is an array
    if ($$o{oq}{select}{$selectAlias}[3]{select} && ref($$o{oq}{select}{$selectAlias}[3]{select}) ne 'ARRAY') {
      my @x = split /\ *\,\ */, $$o{oq}{select}{$selectAlias}[3]{select};
      $$o{oq}{select}{$selectAlias}[3]{select} = \@x;
    }
  }

  # if any fields are passed into on_select, ensure they are always selected
  my $on_select = $$o{q}->param('on_select');
  if ($on_select =~ /[^\,]+\,(.+)/) {
    my @fields = split /\,/, $1;
    for (@fields) {
      $$o{oq}{'select'}{$_}[3]{always_select}=1
        if exists $$o{oq}{'select'}{$_};
    }
  }

  # check schema validity
  $$o{oq}->check_join_counts() if $$o{schema}{check} && ! defined $$o{q}->param('module');

  # install the export tool
  CGI::OptimalQuery::ExportDataTool::activate($o);

  # if savedSearchUserID enable savereport and loadreport tools
  $$o{schema}{savedSearchUserID} ||= undef;
  if ($$o{schema}{savedSearchUserID} =~ /^\d+$/) {
    CGI::OptimalQuery::LoadSearchTool::activate($o);
    CGI::OptimalQuery::SaveSearchTool::activate($o);
  }

  # run on_init function for each enabled tool
  foreach my $v (values %{ $$o{schema}{tools} }) {
    $$v{on_init}->($o) if ref($$v{on_init}) eq 'CODE';
  }

  my $schemaparams = $$o{schema}{params} || {};
  foreach my $k (qw( page rows_page show filter hiddenFilter queryDescr sort mode )) {
    if (exists $$schemaparams{$k}) {
      $$o{$k} = $$schemaparams{$k};
    } elsif (defined $$o{q}->param($k)) {
      $$o{$k} = $$o{q}->param($k);
    } else {
      $$o{$k} = $$o{schema}{$k};
    }
  }

  $$o{mode} ||= 'default';
  $$o{mode} =~ s/\W//g;

  $$o{schema}{results_per_page_picker_nums} ||= [25,50,100,500,1000,'All'];
  $$o{rows_page} ||= $$o{schema}{rows_page} || $$o{schema}{results_per_page_picker_nums}[0] || 10;
  $$o{page} ||= 1;

  # convert show into array
  if (! ref($$o{show})) {
    my @ar = split /\,/, $$o{show};
    $$o{show} = \@ar;
  }

  # if we still don't have something to show then show all cols
  # that aren't hidden
  if (! scalar( @{ $$o{show} } )) {
    for (keys %{ $$o{schema}{select} }) {
      push @{$$o{show}}, $_ unless $$o{oq}->{'select'}->{$_}->[3]->{is_hidden};
    }
  }

  return $o;
}

sub oq  { $_[0]{oq}  }

# ----------- UTILITY METHODS ------------------------------------------------

sub escape_html      { escapeHTML($_[1]) }
sub escape_uri       { CGI::escape($_[1])     }
sub escape_js        {
  my $o = shift;
  $_ = shift;
  s/\\/\\x5C/g;  #escape \
  s/\n/\\x0A/g;  #escape new lines
  s/\'/\\x27/g;  #escape '
  s/\"/\\x22/g;  #escape "
  s/\&/\\x26/g;  #escape &
  s/\r//g;       #remove carriage returns
  s/script/scr\\x69pt/ig; # make nice script tags
  return $_;
}
sub commify {
  my $o = shift;
  my $text = reverse $_[0];
  $text =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
  return scalar reverse $text;
} # Commify


my %no_clone = ('dbh' => 1, 'q' => 1);
sub clone {
  my $thing = shift;
  if (ref($thing) eq 'HASH') {
    my %tmp;
    while (my ($k,$v) = each %$thing) {
      if (exists $no_clone{$k}) { $tmp{$k} = $v; }
      else { $tmp{$k} = clone($v); }
    }
    $thing = \%tmp;
  } elsif (ref($thing) eq 'ARRAY') {
    my @tmp;
    foreach my $v (@$thing) { push @tmp, clone($v); }
    $thing = \@tmp;
  }
  return $thing;
}



#-------------- ACCESSORS --------------------------------------------------
sub sth {
  my ($o) = @_;
  return $$o{sth} if $$o{sth};

  # show is made up of all the fields that should be selected
  my @show; {
    my %show;
    foreach my $colalias (@{$$o{show}}) {
      if (ref($$o{schema}{select}{$colalias}[3]{select}) eq 'ARRAY') {
        $show{$_}=1 for @{ $$o{schema}{select}{$colalias}[3]{select} };
      }
      if ($$o{schema}{select}{$colalias}[1]) {
        $show{$colalias}=1;
      }
    }
    @show = sort keys %show;
  }

  # create & execute SQL statement
  $$o{sth} = $$o{oq}->prepare(
    show   => \@show,
    filter => $$o{filter},
    hiddenFilter => $$o{hiddenFilter},
    forceFilter => $$o{schema}{forceFilter},
    sort   => $$o{sort} );

  # current fetched row
  $$o{rec} = undef;

  # calculate what the limit is
  # and make sure page, num_pages, rows_page make sense
  if ($$o{sth}->count() == 0) {
    $$o{page} = 0;
    $$o{rows_page} = 0;
    $$o{num_pages} = 0;
    $$o{limit} = [0,0];
  } elsif ($$o{rows_page} eq 'All' || ($$o{sth}->count() < $$o{rows_page})) {
    $$o{rows_page} = "All";
    $$o{page} = 1;
    $$o{num_pages} = 1;
    $$o{limit} = [1, $$o{sth}->count()];
  } else {
    $$o{num_pages} = POSIX::ceil($$o{sth}->count() / $$o{rows_page});
    $$o{page} = $$o{num_pages} if $$o{page} > $$o{num_pages};
    my $lo = ($$o{rows_page} * $$o{page}) - $$o{rows_page} + 1;
    my $hi = $lo + $$o{rows_page} - 1;
    $hi = $$o{sth}->count() if $hi > $$o{sth}->count();
    $$o{limit} = [$lo, $hi];
  }

  $$o{sth}->set_limit($$o{limit});

  return $$o{sth};
}
sub get_count        { $_[0]->sth->count() }
sub get_rows_page    { $_[0]{rows_page} }
sub get_current_page { $_[0]{page}      }
sub get_lo_rec       { $_[0]->sth->get_lo_rec() }
sub get_hi_rec       { $_[0]->sth->get_hi_rec() }
sub get_num_pages    { $_[0]{num_pages} }
sub get_title        { $_[0]{schema}{title} }
sub get_filter       { $_[0]->sth->filter_descr() }
sub get_sort         { $_[0]->sth->sort_descr() }
sub get_query        { $_[0]{query}     }
sub get_nice_name    {
  my ($o, $colAlias) = @_;
  return $$o{schema}{select}{$colAlias}[2]
    || join(' ', map { ucfirst } split /[\ \_]+/, $colAlias);
}
sub get_num_usersel_cols { scalar @{$_[0]{show}} }
sub get_usersel_cols { $_[0]{show} }

sub finish {
  my ($o) = @_;
  $$o{sth}->finish() if $$o{sth};
  undef $$o{sth};
}

# get the options
sub get_opts {
  my ($o) = @_;

  if (! $$o{_opts}) {
    my $class = ref $o;

    if (exists $$o{schema}{options}{$class}) {
      $$o{_opts} = $$o{schema}{options}{$class};
    }

    # remove numerics and try again, this allows for module developers to create upgraded modules that use
    # backwards compatible options example: InteractiveQuery & InteractiveQuery2
    elsif ($class =~ s/\d+$// && exists $$o{schema}{options}{$class}) {
      $$o{_opts} = $$o{schema}{options}{$class};
    }

    else {
      $$o{_opts} = {};
    }
  }

  return $$o{_opts};
}

sub fetch {
  my ($o) = @_;
  if ($$o{rec} = $o->sth->fetchrow_hashref()) {
    my $mutator = $o->get_opts()->{'mutateRecord'};
    $mutator->($$o{rec}) if ref($mutator) eq 'CODE';
    $$o{schema}{mutateRecord}->($$o{rec}) if ref($$o{schema}{mutateRecord}) eq 'CODE';
    return $$o{rec};
  }
  return undef;
}

sub get_val {
  my ($o, $colAlias) = @_;
  $o->fetch() unless $$o{rec};
  my $formatter = $$o{schema}{select}{$colAlias}[3]{formatter} || \&default_formatter;
  return $formatter->($$o{rec}{$colAlias}, $$o{rec}, $o, $colAlias);
}

sub get_html_val {
  my ($o, $colAlias) = @_;
  $o->fetch() unless $$o{rec};
  my $formatter = $$o{schema}{select}{$colAlias}[3]{html_formatter} || \&default_html_formatter;
  return $formatter->($$o{rec}{$colAlias}, $$o{rec}, $o, $colAlias);
}

sub default_formatter {
  my ($val) = @_;
  return (ref($val) eq 'ARRAY') ? join(', ', @$val) : $val;
}

sub default_html_formatter {
  my ($val, $rec, $o, $colAlias) = @_;
  if (! exists $$o{_noEscapeColMap}) {
    my %noEsc = map { $_ => 1 } @{ $o->get_opts()->{'noEscapeCol'} || [] };
    $$o{_noEscapeColMap} = \%noEsc;
  }
  if ($$o{_noEscapeColMap}{$colAlias}) {
    $val = join(' ', @$val) if ref($val) eq 'ARRAY';
  } elsif (ref($val) eq 'ARRAY') {
    $val = join(', ', map { escapeHTML($_) } @$val);
  } else {
    $val = escapeHTML($val);
  }
  return $val;
}

sub recview_formatter {
  my ($val, $rec, $o, $colAlias) = @_;

  my @val;
  foreach my $colAlias2 (@{ $$o{schema}{select}{$colAlias}[3]{select} }) {
    my $val2 = default_formatter($$rec{$colAlias2});
    if ($val2 ne '') {
      my $label = $$o{schema}{select}{$colAlias2}[2] || $colAlias2;
      push @val, "$label: $val2";
    }
  }
  return join("\n", @val);
}

sub recview_html_formatter {
  my ($val, $rec, $o, $colAlias) = @_;

  my @val;
  foreach my $colAlias2 (@{ $$o{schema}{select}{$colAlias}[3]{select} }) {
    my $val2 = $o->get_html_val($colAlias2);
    if ($val2 ne '') {
      my $label = $$o{schema}{select}{$colAlias2}[2] || $colAlias2;
      push @val, "
    }
  }
  return $#val > -1 ? "".join('', @val)."" : '';
}

sub get_link {
  my ($o) = @_;
  my @args;
  foreach my $k (qw( show filter hiddenFilter queryDescr sort)) {
    my $v1 = $$o{$k};
    $v1 = join(',', @$v1) if ref($v1) eq 'ARRAY';
    my $v2 = $$o{schema}{$k};
    $v2 = join(',', @$v2) if ref($v2) eq 'ARRAY';
    push @args, "$k=".CGI::escape($v1) if $v1 ne $v2;
  }
  my $rv = $$o{schema}{URI};
  my $args = join('&', @args);
  $rv .= '?'.$args if $args;
  return $rv;
}

1;