File Coverage

lib/CGI/OptimalQuery/Base.pm
Criterion Covered Total %
statement 33 275 12.0
branch 0 132 0.0
condition 0 49 0.0
subroutine 11 46 23.9
pod 0 34 0.0
total 44 536 8.2


";
line stmt bran cond sub pod time code
1             package CGI::OptimalQuery::Base;
2              
3 1     1   756 use strict;
  1         1  
  1         24  
4 1     1   3 use warnings;
  1         2  
  1         25  
5 1     1   4 no warnings qw( uninitialized );
  1         1  
  1         26  
6 1     1   766 use CGI();
  1         20763  
  1         24  
7 1     1   7 use Carp('confess');
  1         1  
  1         44  
8 1     1   504 use POSIX();
  1         4233  
  1         21  
9 1     1   6 use DBIx::OptimalQuery;
  1         1  
  1         16  
10 1     1   575 use JSON::XS;
  1         3544  
  1         46  
11              
12             # some tools that OQ auto activates
13 1     1   317 use CGI::OptimalQuery::ExportDataTool();
  1         2  
  1         14  
14 1     1   375 use CGI::OptimalQuery::SaveSearchTool();
  1         1  
  1         19  
15 1     1   313 use CGI::OptimalQuery::LoadSearchTool();
  1         2  
  1         2412  
16              
17             sub escapeHTML {
18 0 0   0 0   return defined $_[0] ? CGI::escapeHTML($_[0]) : '';
19             }
20              
21 0     0 0   sub can_embed { 0 }
22              
23             # alias for output
24             sub print {
25 0     0 0   my $o = shift;
26 0           $o->output(@_);
27             }
28              
29             sub new {
30 0     0 0   my $pack = shift;
31 0           my $schema = shift;
32 0 0         die "could not find schema!" unless ref($schema) eq 'HASH';
33              
34 0           my $o = bless {}, $pack;
35              
36 0           $$o{schema} = clone($schema);
37              
38             $$o{dbh} = $$o{schema}{dbh}
39 0 0         or confess "couldn't find dbh in schema!";
40             $$o{q} = $$o{schema}{q}
41 0 0         or confess "couldn't find q in schema!";
42 0           $$o{output_handler} = $$o{schema}{output_handler};
43 0           $$o{error_handler} = $$o{schema}{error_handler};
44              
45             # check for required attributes
46             confess "specified select is not a hash ref!"
47 0 0         unless ref $$o{schema}{select} eq "HASH";
48             confess "specified joins is not a hash ref!"
49 0 0         unless ref $$o{schema}{joins} eq "HASH";
50            
51             # set defaults
52 0   0       $$o{schema}{debug} ||= 0;
53             $$o{schema}{check} = $ENV{'CGI-OPTIMALQUERY_CHECK'}
54 0 0         if ! defined $$o{schema}{check};
55 0 0         $$o{schema}{check} = 0 if ! defined $$o{schema}{check};
56 0   0       $$o{schema}{title} ||= "";
57 0   0       $$o{schema}{options} ||= {};
58 0   0       $$o{schema}{resourceURI} ||= $ENV{OPTIMALQUERY_RESOURCES} || '/OptimalQuery';
      0        
59              
60 0 0         if (! $$o{schema}{URI}) {
61 0 0         $_ = ($$o{q}->can('uri')) ? $$o{q}->uri() : $ENV{REQUEST_URI}; s/\?.*$//;
  0            
62 0           $$o{schema}{URI} = $_;
63             # disabled so we can run from command line for testing where REQUEST_URI probably isn't defined
64             # or die "could not find 'URI' in schema";
65             }
66              
67 0   0       $$o{schema}{URI_standalone} ||= $$o{schema}{URI};
68              
69             # make sure developer is not using illegal state_params
70 0 0         if (ref($$o{schema}{state_params}) eq 'ARRAY') {
71 0           foreach my $p (@{ $$o{schema}{state_params} }) {
  0            
72 0 0         die "cannot use reserved state param name: act" if $p eq 'act';
73 0 0         die "cannot use reserved state param name: module" if $p eq 'module';
74 0 0         die "cannot use reserved state param name: view" if $p eq 'view';
75             }
76             }
77              
78             # construct optimal query object
79             $$o{oq} = DBIx::OptimalQuery->new(
80             'dbh' => $$o{schema}{dbh},
81             'select' => $$o{schema}{select},
82             'joins' => $$o{schema}{joins},
83             'named_filters' => $$o{schema}{named_filters},
84             'named_sorts' => $$o{schema}{named_sorts},
85             'debug' => $$o{schema}{debug},
86             'error_handler' => $$o{schema}{error_handler}
87 0           );
88              
89             # the following code is responsible for setting the disable_sort flag for all
90             # multi valued selects (since it never makes since to sort a m-valued column)
91 0           my %cached_dep_multival_status;
92             my $find_dep_multival_status_i;
93 0           my $find_dep_multival_status;
94             $find_dep_multival_status = sub {
95 0     0     my $joinAlias = shift;
96 0           $find_dep_multival_status_i++;
97 0 0         die "could not resolve join alias: $joinAlias deps" if $find_dep_multival_status_i > 100;
98 0 0         if (! exists $cached_dep_multival_status{$joinAlias}) {
99 0           my $v;
100 0 0         if (exists $$o{oq}{joins}{$joinAlias}[3]{new_cursor}) { $v = 0; }
  0 0          
101 0           elsif (! @{ $$o{oq}{joins}{$joinAlias}[0] }) { $v = 1; }
  0            
102 0           else { $v = $find_dep_multival_status->($$o{oq}{joins}{$joinAlias}[0][0]); }
103 0           $cached_dep_multival_status{$joinAlias} = $v;
104             }
105 0           return $cached_dep_multival_status{$joinAlias};
106 0           };
107              
108             # loop though all selects
109 0           foreach my $selectAlias (keys %{ $$o{oq}{select} }) {
  0            
110 0           $find_dep_multival_status_i = 0;
111              
112             # set the disable sort flag is select is a multi value
113             $$o{oq}{select}{$selectAlias}[3]{disable_sort} = 1
114 0 0         if ! $find_dep_multival_status->($$o{oq}{select}{$selectAlias}[0][0]);
115              
116             # set is_hidden flag if select does not have a nice name assigned
117             $$o{oq}{select}{$selectAlias}[3]{is_hidden} = 1
118 0 0         if ! $$o{oq}{select}{$selectAlias}[2];
119              
120             # if no SQL (could be a recview) then disable sort, filter
121 0 0         if (! $$o{oq}{select}{$selectAlias}[1]) {
122 0           $$o{oq}{select}{$selectAlias}[3]{disable_sort} = 1;
123 0           $$o{oq}{select}{$selectAlias}[3]{disable_filter} = 1;
124             }
125              
126             # if a select column has additional select fields specified in options, make sure that the options array is an array
127 0 0 0       if ($$o{oq}{select}{$selectAlias}[3]{select} && ref($$o{oq}{select}{$selectAlias}[3]{select}) ne 'ARRAY') {
128 0           my @x = split /\ *\,\ */, $$o{oq}{select}{$selectAlias}[3]{select};
129 0           $$o{oq}{select}{$selectAlias}[3]{select} = \@x;
130             }
131             }
132              
133             # if any fields are passed into on_select, ensure they are always selected
134 0           my $on_select = $$o{q}->param('on_select');
135 0 0         if ($on_select =~ /[^\,]+\,(.+)/) {
136 0           my @fields = split /\,/, $1;
137 0           for (@fields) {
138             $$o{oq}{'select'}{$_}[3]{always_select}=1
139 0 0         if exists $$o{oq}{'select'}{$_};
140             }
141             }
142              
143             # check schema validity
144 0 0 0       $$o{oq}->check_join_counts() if $$o{schema}{check} && ! defined $$o{q}->param('module');
145              
146             # install the export tool
147 0           CGI::OptimalQuery::ExportDataTool::activate($o);
148              
149             # if savedSearchUserID enable savereport and loadreport tools
150 0   0       $$o{schema}{savedSearchUserID} ||= undef;
151 0 0         if ($$o{schema}{savedSearchUserID} =~ /^\d+$/) {
152 0           CGI::OptimalQuery::LoadSearchTool::activate($o);
153 0           CGI::OptimalQuery::SaveSearchTool::activate($o);
154             }
155              
156             # run on_init function for each enabled tool
157 0           foreach my $v (values %{ $$o{schema}{tools} }) {
  0            
158 0 0         $$v{on_init}->($o) if ref($$v{on_init}) eq 'CODE';
159             }
160              
161             # if schema params exist
162 0 0         if (ref($$o{schema}{params}) eq 'HASH') {
163 0           foreach my $k (qw( page rows_page show filter hiddenFilter queryDescr sort mode )) {
164 0 0         $$o{$k} = $$o{schema}{params}{$k} if exists $$o{schema}{params}{$k};
165             }
166             }
167              
168             # else use CGI params
169             else {
170 0           foreach my $k (qw( page rows_page show filter hiddenFilter queryDescr sort mode )) {
171 0 0         next unless defined $$o{q}->param($k);
172 0           $$o{$k} = $$o{q}->param($k);
173             }
174             }
175              
176             # use schema defaults when no user defaults are available
177 0           foreach my $k (qw( show filter hiddenFilter queryDescr sort mode)) {
178 0 0         $$o{$k} = $$o{schema}{$k} unless defined $$o{$k};
179             }
180              
181 0   0       $$o{mode} ||= 'default';
182 0           $$o{mode} =~ s/\W//g;
183              
184 0   0       $$o{schema}{results_per_page_picker_nums} ||= [25,50,100,500,1000,'All'];
185 0   0       $$o{rows_page} ||= $$o{schema}{rows_page} || $$o{schema}{results_per_page_picker_nums}[0] || 10;
      0        
186 0   0       $$o{page} ||= 1;
187              
188             # convert show into array
189 0 0         if (! ref($$o{show})) {
190 0           my @ar = split /\,/, $$o{show};
191 0           $$o{show} = \@ar;
192             }
193              
194             # if we still don't have something to show then show all cols
195             # that aren't hidden
196 0 0         if (! scalar( @{ $$o{show} } )) {
  0            
197 0           for (keys %{ $$o{schema}{select} }) {
  0            
198 0 0         push @{$$o{show}}, $_ unless $$o{oq}->{'select'}->{$_}->[3]->{is_hidden};
  0            
199             }
200             }
201              
202 0           return $o;
203             }
204              
205 0     0 0   sub oq { $_[0]{oq} }
206              
207             # ----------- UTILITY METHODS ------------------------------------------------
208              
209 0     0 0   sub escape_html { escapeHTML($_[1]) }
210 0     0 0   sub escape_uri { CGI::escape($_[1]) }
211             sub escape_js {
212 0     0 0   my $o = shift;
213 0           $_ = shift;
214 0           s/\\/\\x5C/g; #escape \
215 0           s/\n/\\x0A/g; #escape new lines
216 0           s/\'/\\x27/g; #escape '
217 0           s/\"/\\x22/g; #escape "
218 0           s/\&/\\x26/g; #escape &
219 0           s/\r//g; #remove carriage returns
220 0           s/script/scr\\x69pt/ig; # make nice script tags
221 0           return $_;
222             }
223             sub commify {
224 0     0 0   my $o = shift;
225 0           my $text = reverse $_[0];
226 0           $text =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
227 0           return scalar reverse $text;
228             } # Commify
229              
230              
231             my %no_clone = ('dbh' => 1, 'q' => 1);
232             sub clone {
233 0     0 0   my $thing = shift;
234 0 0         if (ref($thing) eq 'HASH') {
    0          
235 0           my %tmp;
236 0           while (my ($k,$v) = each %$thing) {
237 0 0         if (exists $no_clone{$k}) { $tmp{$k} = $v; }
  0            
238 0           else { $tmp{$k} = clone($v); }
239             }
240 0           $thing = \%tmp;
241             } elsif (ref($thing) eq 'ARRAY') {
242 0           my @tmp;
243 0           foreach my $v (@$thing) { push @tmp, clone($v); }
  0            
244 0           $thing = \@tmp;
245             }
246 0           return $thing;
247             }
248              
249              
250              
251             #-------------- ACCESSORS --------------------------------------------------
252             sub sth {
253 0     0 0   my ($o) = @_;
254 0 0         return $$o{sth} if $$o{sth};
255              
256             # show is made up of all the fields that should be selected
257 0           my @show; {
258 0           my %show;
  0            
259 0           foreach my $colalias (@{$$o{show}}) {
  0            
260 0 0         if (ref($$o{schema}{select}{$colalias}[3]{select}) eq 'ARRAY') {
261 0           $show{$_}=1 for @{ $$o{schema}{select}{$colalias}[3]{select} };
  0            
262             }
263 0 0         if ($$o{schema}{select}{$colalias}[1]) {
264 0           $show{$colalias}=1;
265             }
266             }
267 0           @show = sort keys %show;
268             }
269              
270             # create & execute SQL statement
271             $$o{sth} = $$o{oq}->prepare(
272             show => \@show,
273             filter => $$o{filter},
274             hiddenFilter => $$o{hiddenFilter},
275             forceFilter => $$o{schema}{forceFilter},
276 0           sort => $$o{sort} );
277              
278             # current fetched row
279 0           $$o{rec} = undef;
280              
281             # calculate what the limit is
282             # and make sure page, num_pages, rows_page make sense
283 0 0 0       if ($$o{sth}->count() == 0) {
    0          
284 0           $$o{page} = 0;
285 0           $$o{rows_page} = 0;
286 0           $$o{num_pages} = 0;
287 0           $$o{limit} = [0,0];
288             } elsif ($$o{rows_page} eq 'All' || ($$o{sth}->count() < $$o{rows_page})) {
289 0           $$o{rows_page} = "All";
290 0           $$o{page} = 1;
291 0           $$o{num_pages} = 1;
292 0           $$o{limit} = [1, $$o{sth}->count()];
293             } else {
294 0           $$o{num_pages} = POSIX::ceil($$o{sth}->count() / $$o{rows_page});
295 0 0         $$o{page} = $$o{num_pages} if $$o{page} > $$o{num_pages};
296 0           my $lo = ($$o{rows_page} * $$o{page}) - $$o{rows_page} + 1;
297 0           my $hi = $lo + $$o{rows_page} - 1;
298 0 0         $hi = $$o{sth}->count() if $hi > $$o{sth}->count();
299 0           $$o{limit} = [$lo, $hi];
300             }
301              
302 0           $$o{sth}->set_limit($$o{limit});
303              
304 0           return $$o{sth};
305             }
306 0     0 0   sub get_count { $_[0]->sth->count() }
307 0     0 0   sub get_rows_page { $_[0]{rows_page} }
308 0     0 0   sub get_current_page { $_[0]{page} }
309 0     0 0   sub get_lo_rec { $_[0]->sth->get_lo_rec() }
310 0     0 0   sub get_hi_rec { $_[0]->sth->get_hi_rec() }
311 0     0 0   sub get_num_pages { $_[0]{num_pages} }
312 0     0 0   sub get_title { $_[0]{schema}{title} }
313 0     0 0   sub get_filter { $_[0]->sth->filter_descr() }
314 0     0 0   sub get_sort { $_[0]->sth->sort_descr() }
315 0     0 0   sub get_query { $_[0]{query} }
316 0     0 0   sub get_nice_name { $_[0]{schema}{select}{$_[1]}[2] }
317 0     0 0   sub get_num_usersel_cols { scalar @{$_[0]{show}} }
  0            
318 0     0 0   sub get_usersel_cols { $_[0]{show} }
319              
320             sub finish {
321 0     0 0   my ($o) = @_;
322 0 0         $$o{sth}->finish() if $$o{sth};
323 0           undef $$o{sth};
324             }
325              
326             # get the options
327             sub get_opts {
328 0     0 0   my ($o) = @_;
329              
330 0 0         if (! $$o{_opts}) {
331 0           my $class = ref $o;
332              
333 0 0 0       if (exists $$o{schema}{options}{$class}) {
    0          
334 0           $$o{_opts} = $$o{schema}{options}{$class};
335             }
336              
337             # remove numerics and try again, this allows for module developers to create upgraded modules that use
338             # backwards compatible options example: InteractiveQuery & InteractiveQuery2
339             elsif ($class =~ s/\d+$// && exists $$o{schema}{options}{$class}) {
340 0           $$o{_opts} = $$o{schema}{options}{$class};
341             }
342              
343             else {
344 0           $$o{_opts} = {};
345             }
346             }
347              
348 0           return $$o{_opts};
349             }
350              
351             sub fetch {
352 0     0 0   my ($o) = @_;
353 0 0         if ($$o{rec} = $o->sth->fetchrow_hashref()) {
354 0           my $mutator = $o->get_opts()->{'mutateRecord'};
355 0 0         $mutator->($$o{rec}) if ref($mutator) eq 'CODE';
356 0 0         $$o{schema}{mutateRecord}->($$o{rec}) if ref($$o{schema}{mutateRecord}) eq 'CODE';
357 0           return $$o{rec};
358             }
359 0           return undef;
360             }
361              
362             sub get_val {
363 0     0 0   my ($o, $colAlias) = @_;
364 0 0         $o->fetch() unless $$o{rec};
365 0   0       my $formatter = $$o{schema}{select}{$colAlias}[3]{formatter} || \&default_formatter;
366 0           return $formatter->($$o{rec}{$colAlias}, $$o{rec}, $o, $colAlias);
367             }
368              
369             sub get_html_val {
370 0     0 0   my ($o, $colAlias) = @_;
371 0 0         $o->fetch() unless $$o{rec};
372 0   0       my $formatter = $$o{schema}{select}{$colAlias}[3]{html_formatter} || \&default_html_formatter;
373 0           return $formatter->($$o{rec}{$colAlias}, $$o{rec}, $o, $colAlias);
374             }
375              
376             sub default_formatter {
377 0     0 0   my ($val) = @_;
378 0 0         return (ref($val) eq 'ARRAY') ? join(', ', @$val) : $val;
379             }
380              
381             sub default_html_formatter {
382 0     0 0   my ($val, $rec, $o, $colAlias) = @_;
383 0 0         if (! exists $$o{_noEscapeColMap}) {
384 0 0         my %noEsc = map { $_ => 1 } @{ $o->get_opts()->{'noEscapeCol'} || [] };
  0            
  0            
385 0           $$o{_noEscapeColMap} = \%noEsc;
386             }
387 0 0         if ($$o{_noEscapeColMap}{$colAlias}) {
    0          
388 0 0         $val = join(' ', $val) if ref($val) eq 'ARRAY';
389             } elsif (ref($val) eq 'ARRAY') {
390 0           $val = join(', ', map { escapeHTML($_) } @$val);
  0            
391             } else {
392 0           $val = escapeHTML($val);
393             }
394 0           return $val;
395             }
396              
397             sub recview_formatter {
398 0     0 0   my ($val, $rec, $o, $colAlias) = @_;
399              
400 0           my @val;
401 0           foreach my $colAlias2 (@{ $$o{schema}{select}{$colAlias}[3]{select} }) {
  0            
402 0           my $val2 = default_formatter($$rec{$colAlias2});
403 0 0         if ($val2 ne '') {
404 0   0       my $label = $$o{schema}{select}{$colAlias2}[2] || $colAlias2;
405 0           push @val, "$label: $val2";
406             }
407             }
408 0           return join("\n", @val);
409             }
410              
411             sub recview_html_formatter {
412 0     0 0   my ($val, $rec, $o, $colAlias) = @_;
413              
414 0           my @val;
415 0           foreach my $colAlias2 (@{ $$o{schema}{select}{$colAlias}[3]{select} }) {
  0            
416 0           my $val2 = $o->get_html_val($colAlias2);
417 0 0         if ($val2 ne '') {
418 0   0       my $label = $$o{schema}{select}{$colAlias2}[2] || $colAlias2;
419 0           push @val, "
".escapeHTML($label)."$val2
420             }
421             }
422 0 0         return $#val > -1 ? "".join('', @val)."
" : '';
423             }
424              
425             sub get_link {
426 0     0 0   my ($o) = @_;
427 0           my @args;
428 0           foreach my $k (qw( show filter hiddenFilter queryDescr sort)) {
429 0           my $v1 = $$o{$k};
430 0 0         $v1 = join(',', @$v1) if ref($v1) eq 'ARRAY';
431 0           my $v2 = $$o{schema}{$k};
432 0 0         $v2 = join(',', @$v2) if ref($v2) eq 'ARRAY';
433 0 0         push @args, "$k=".CGI::escape($v1) if $v1 ne $v2;
434             }
435 0           my $rv = $$o{schema}{URI};
436 0           my $args = join('&', @args);
437 0 0         $rv .= '?'.$args if $args;
438 0           return $rv;
439             }
440              
441             1;