[Bio] / Sprout / ERDBQueryConsole.pm Repository:
ViewVC logotype

Annotation of /Sprout/ERDBQueryConsole.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (view) (download) (as text)

1 : parrello 1.1 #!/usr/bin/perl -w
2 :    
3 :     #
4 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
5 :     # for Interpretations of Genomes. All Rights Reserved.
6 :     #
7 :     # This file is part of the SEED Toolkit.
8 :     #
9 :     # The SEED Toolkit is free software. You can redistribute
10 :     # it and/or modify it under the terms of the SEED Toolkit
11 :     # Public License.
12 :     #
13 :     # You should have received a copy of the SEED Toolkit Public License
14 :     # along with this program; if not write to the University of Chicago
15 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
16 :     # Genomes at veronika@thefig.info or download a copy from
17 :     # http://www.theseed.org/LICENSE.TXT.
18 :     #
19 :    
20 :     package ERDBQueryConsole;
21 :    
22 :     use strict;
23 :     use Tracer;
24 :     use CGI;
25 :     use ERDB;
26 :     use Stats;
27 :    
28 :     =head1 ERDB Query Console Helper
29 :    
30 :     =head2 Introduction
31 :    
32 :     This is a simple helper class used by the ERDB Query Console. The console
33 :     appears in two places: once as a SeedViewer page, and once as an NMPDR plugin
34 :     Wiki console. Each of these places is responsible for insuring that the user has
35 :     the proper credentials and then calling this package's main method. To construct
36 :     a console helper, simply pass in the database name and the user's security
37 :     level, then call L</Submit> to validate the parameters and build the query. If
38 :     there are problems, call L</Errors> to get a list of error messages. If
39 :     everything went fine, call L</Headers> to get the names and styles for the result
40 :     columns and then L</GetRow> to get the individual result rows. The row elements
41 :     will be pre-encoded into HTML.
42 :    
43 :     The fields in this object are as follows.
44 :    
45 :     =over 4
46 :    
47 :     =item erdb
48 :    
49 :     [[ErdbPm]] database object for the current database.
50 :    
51 :     =item query
52 :    
53 :     [[ERDBQueryPm]] object for obtaining the query results.
54 :    
55 :     =item fields
56 :    
57 :     Reference to a list of result field information, in order. For
58 :     each result field, the list contains a hash consisting of the
59 :     field name (C<name>), a flag indicating whether or not it is
60 :     secondary (C<secondary>), and a reference to the field's
61 :     type object (C<type>).
62 :    
63 :     =item objects
64 :    
65 :     Object name string for the query.
66 :    
67 :     =item filterString
68 :    
69 :     Filter string for the query.
70 :    
71 :     =item parms
72 :    
73 :     Reference to a list of parameter values. There should be one parameter
74 :     value for each parameter mark in the query.
75 :    
76 :     =item secure
77 :    
78 :     TRUE if the user is privileged, else FALSE.
79 :    
80 :     =item stats
81 :    
82 :     Statistics object.
83 :    
84 :     =back
85 :    
86 :     =cut
87 :    
88 :     =head3 new
89 :    
90 :     my $eq = ERDBQueryConsole->new($db, %options);
91 :    
92 :     Construct a new ERDBQueryConsole object. The parameters are as follows.
93 :    
94 :     =over 4
95 :    
96 :     =item db
97 :    
98 :     Database against which to run the query. This can be either an [[ErdbPm]]
99 :     object for the database or a string containing the database name.
100 :    
101 :     =item options
102 :    
103 :     A hash of constructor options.
104 :    
105 :     =back
106 :    
107 :     The following options are supported.
108 :    
109 :     =over 4
110 :    
111 :     =item secure
112 :    
113 :     TRUE if the user is privileged and can make unlimited queries. The default
114 :     is FALSE.
115 :    
116 :     =back
117 :    
118 :     =cut
119 :    
120 :     sub new {
121 :     # Get the parameters.
122 :     my ($class, $db, %options) = @_;
123 :     # Get the options.
124 :     my $secure = $options{secure} || 0;
125 :     # Get access to the database.
126 :     my $erdb;
127 :     if (! ref $db) {
128 :     $erdb = ERDB::GetDatabase($db);
129 :     } else {
130 :     $erdb = $db;
131 :     }
132 :     # Create the ERDBQueryConsole object.
133 :     my $retVal = {
134 :     erdb => $erdb,
135 :     secure => $secure,
136 :     };
137 :     # Bless and return it.
138 :     bless $retVal, $class;
139 :     return $retVal;
140 :     }
141 :    
142 :     =head2 Public Methods
143 :    
144 :     =head3 Submit
145 :    
146 :     my $okFlag = $eq->Submit($objects, $filterString, \@parms, \@fields, $limitNumber);
147 :    
148 :     Submit a query to the console. This method stores the relevant
149 :     information about the query and creates the query object. Other methods
150 :     can be used to get the results of the query or a list of error messages.
151 :    
152 :     =over 4
153 :    
154 :     =item objects
155 :    
156 :     Object name string containing the list of objects that particpate in the
157 :     query.
158 :    
159 :     =item filterString
160 :    
161 :     Filter string for the query, specifying the query conditions, sort order,
162 :     and limit.
163 :    
164 :     =item parms
165 :    
166 :     Reference to a list of parameter values. Each parameter value is plugged
167 :     into a parameter mark in the filter string.
168 :    
169 :     =item fields
170 :    
171 :     List of result field names.
172 :    
173 :     =item limitNumber
174 :    
175 :     Maximum number of rows for the query. If the user is not privileged,
176 :    
177 :     =item RETURN
178 :    
179 :     Returns TRUE if the query was successful, FALSE if an error was
180 :     detected.
181 :    
182 :     =back
183 :    
184 :     =cut
185 :    
186 :     sub Submit {
187 :     # Get the parameters.
188 :     my ($self, $objects, $filterString, $parms, $fields, $limitNumber) = @_;
189 :     # Clear this object for a new query.
190 :     $self->Clear();
191 :     # Count the parameter marks in the filter string.
192 :     my $parmCount = ERDB::CountParameterMarks($filterString);
193 :     # Count the parameters.
194 :     my $suppliedParms = scalar(@$parms);
195 :     Trace("$suppliedParms parameters found.") if T(3);
196 :     # Verify the various parameters.
197 :     if (! $objects) {
198 :     $self->Error("No object list specified. Query aborted.");
199 :     } elsif (! $fields) {
200 :     $self->Error("No output fields specified. Query aborted.");
201 :     } elsif ($parmCount > $suppliedParms) {
202 :     $self->Error("You have $parmCount parameter marks but only $suppliedParms " .
203 :     "Parameters. Insure each parameter is on a separate line in " .
204 :     "the parameters box and that you don't have any extra question " .
205 :     "marks (?) in the Filter String.");
206 :     } elsif ($parmCount < $suppliedParms) {
207 :     $self->Error("You have $suppliedParms Parameters but there are only " .
208 :     "$parmCount parameter marks in the Filter String.")
209 :     } else {
210 :     # Now we can do the query. First, get the database object.
211 :     my $db = $self->{erdb};
212 :     # Parse the object name list.
213 :     my @nameErrors = $db->CheckObjectNames($objects);
214 :     if (@nameErrors) {
215 :     # Here there were errors in the object name string.
216 :     for my $nameError (@nameErrors) {
217 :     $self->Error($nameError);
218 :     }
219 :     $self->Error("Errors were found in the Object Names.");
220 :     } else {
221 :     # Check to see if we need to limit this query.
222 :     my $limitClause = "";
223 :     if (! $self->{secure}) {
224 :     # We do. Check for an existing limit.
225 :     if ($filterString =~ /(.+)\s+LIMIT\s+(\d+)(.*)/) {
226 :     # Fix it if it's too big.
227 :     if ($2 >= $FIG_Config::query_limit) {
228 :     $filterString = "$1 LIMIT $FIG_Config::query_limit$3";
229 :     }
230 :     } else {
231 :     # No limit present, so add one.
232 :     $limitClause = " LIMIT $FIG_Config::query_limit";
233 :     }
234 :     } else {
235 :     # Privileged users can request a different limit. Only use it
236 :     # if there is not already a limit in the filter clause.
237 :     if ($limitNumber && $filterString !~ /\sLIMIT\s/) {
238 :     $limitClause = " LIMIT $limitNumber";
239 :     Trace("Limit clause for $limitNumber rows added to query.") if T(2);
240 :     }
241 :     }
242 :     # Now we need to find things out about the fields. For each one,
243 :     # we need a column name and a cell format. To get that, we
244 :     # start the query and analyze the fields.
245 :     Trace("Preparing query.") if T(3);
246 :     my $query = eval('$db->Prepare($objects, "$filterString$limitClause", $parms)');
247 :     if ($@) {
248 :     # Here the query preparation failed for some reason. This is usually an
249 :     # SQL syntax error.
250 :     $self->Error("QUERY ERROR: $@");
251 :     } else {
252 :     Trace("Parsing field list.") if T(3);
253 :     # We need to get the necessary data for each field in the field list.
254 :     # This will be set to TRUE if a valid field is found.
255 :     my $found;
256 :     # Now loop through the field names.
257 :     for my $field (@$fields) {
258 :     Trace("Processing field name \"$field\".") if T(3);
259 :     # Get the data for this field.
260 :     my ($objectName, $fieldName, $type) = $query->CheckFieldName($field);
261 :     if (! defined $objectName) {
262 :     # Here the field specification had an invalid format.
263 :     $self->Error("Field specifier \"$field\" has an invalid format.");
264 :     } elsif (! defined $fieldName) {
265 :     # Here the object name was invalid. That generates a warning.
266 :     $self->Error("Object name \"$objectName\" not found in query.");
267 :     } elsif (! defined $type) {
268 :     # Here the field name was invalid. That is also a warning.
269 :     $self->Error("Field \"$fieldName\" not found in $objectName.");
270 :     } else {
271 :     # Here the field name is okay. Save its data.
272 :     push @{$self->{fields}},
273 :     { name => $field, type => $type,
274 :     secondary => $db->IsSecondary($fieldName, $objectName)
275 :     };
276 :     # Count the field.
277 :     $self->AddStat(fields => 1);
278 :     $found = 1;
279 :     }
280 :     }
281 :     # Insure we have at least one valid field.
282 :     if (! $found) {
283 :     $self->Error("No valid field names were specified for this query.");
284 :     } else {
285 :     # We do, so save the query and its parameters.
286 :     $self->{query} = $query;
287 :     $self->{parms} = $parms;
288 :     $self->{objects} = $objects;
289 :     $self->{filterString} = $filterString;
290 :     }
291 :     }
292 :     }
293 :     }
294 :     # Return TRUE if no errors were detected.
295 :     return defined $self->{query};
296 :     }
297 :    
298 :     =head3 Headers
299 :    
300 :     my @columnData = $eq->Headers();
301 :    
302 :     Return the header information for each column of the output. The header
303 :     information is returned as a list of 2-tuples. For each column, the
304 :     2-tuple includes the column caption and the alignment (C<left>, C<right>,
305 :     or C<center>).
306 :    
307 :     =cut
308 :    
309 :     sub Headers {
310 :     # Get the parameters.
311 :     my ($self) = @_;
312 :     # Declare the return variable.
313 :     my @retVal;
314 :     # Insure we have fields. If we don't, the query will be treated as
315 :     # having 0 output columns: we'll return an empty list.
316 :     if (defined $self->{fields}) {
317 :     # We have something, so loop through the fields.
318 :     for my $field (@{$self->{fields}}) {
319 :     # Compute the alignment.
320 :     my $align = $field->{type}->align();
321 :     # Push it into the result list along with the field name.
322 :     push @retVal, [$field->{name}, $align];
323 :     }
324 :     }
325 :     # Return the result.
326 :     return @retVal;
327 :     }
328 :    
329 :     =head3 GetRow
330 :    
331 :     my @items = $eq->GetRow();
332 :    
333 :     Get the next row of data from the query. Each row will consist of a list
334 :     of HTML strings, one per result column, in the same order the field names
335 :     appeared when the query was submitted.
336 :    
337 :     If the query is complete, an empty list will be returned.
338 :    
339 :     =cut
340 :    
341 :     sub GetRow {
342 :     # Get the parameters.
343 :     my ($self) = @_;
344 :     # Declare the return variable.
345 :     my @retVal;
346 :     # Only proceed if we have an active query.
347 :     if (defined $self->{query}) {
348 :     # We do, so try to get the next record. Note we accumulate the
349 :     # time spent and protect from errors.
350 :     my $start = time();
351 :     my $record = $self->{query}->Fetch();
352 :     $self->AddStat(duration => time() - $start);
353 :     # Only proceed if a record was found.
354 :     if (defined $record) {
355 :     # Now we have the data for this row, and it's time to
356 :     # stuff it into the return list. Loop through the fields.
357 :     for my $field (@{$self->{fields}}) {
358 :     # Get the values for this field.
359 :     my @values = $record->Value($field->{name});
360 :     $self->AddStat(values => scalar(@values));
361 :     # Get the field type.
362 :     my $type = $field->{type};
363 :     # Convert the values to HTML and string them together.
364 :     my $cell = join("<br />", map { $type->html($_) } @values);
365 :     # Put the result into the output list.
366 :     push @retVal, $cell;
367 :     }
368 :     }
369 :     }
370 :     # Return the result.
371 :     return @retVal;
372 :     }
373 :    
374 :     =head3 GetCode
375 :    
376 :     my $codeString = $eq->GetCode($dbVarName, $codeStyle, @parameters);
377 :    
378 :     Return the PERL code to perform the query submitted to this console.
379 :    
380 :     =over 4
381 :    
382 :     =item dbVarName
383 :    
384 :     Name to give to the variable containing the database object.
385 :    
386 :     =item codeStyle
387 :    
388 :     Coding style to use: C<Get> for a get loop, C<GetAll> for a single get-all
389 :     statement.
390 :    
391 :     =item parameters
392 :    
393 :     List of parameter names. If a parameter name is a string, then the
394 :     corresponding parameter will be encoded as a variable with the name
395 :     given by the string. If a parameter name is an undefined value, the
396 :     parameter value will be encoded as a constant.
397 :    
398 :     =item RETURN
399 :    
400 :     Returns a string containing the PERL code to duplicate the incoming
401 :     query.
402 :    
403 :     =back
404 :    
405 :     =cut
406 :    
407 :     sub GetCode {
408 :     # Get the parameters.
409 :     my ($self, $dbVarName, $codeStyle, @parameters) = @_;
410 :     # We'll create lines of PERL code in here.
411 :     my @codeLines;
412 :     # We'll use this constant for tabbing purposes.
413 :     my $tab = " " x 4;
414 :     # Compute the name of the database object.
415 :     my $dbObjectName = '$' . $dbVarName;
416 :     # We start with some USE statements.
417 :     push @codeLines, "use ERDB;",
418 :     "use Tracer;";
419 :     # Get the field list. We'll be using it a lot.
420 :     my $fields = $self->{fields};
421 :     # Add "use" statements for all the field types. We build a hash
422 :     # to prevent duplicates.
423 :     my %uses;
424 :     for my $field (@$fields) {
425 :     my $type = $field->{type}->objectType();
426 :     if ($type) {
427 :     $uses{$type} = 1;
428 :     }
429 :     }
430 :     push @codeLines, map { "use $_;" } sort keys %uses;
431 :     # Now create the database object.
432 :     my $dbType = ref $self->{erdb};
433 :     push @codeLines, "",
434 :     "my $dbObjectName = ERDB::GetDatabase('$dbType');",
435 :     "";
436 :     # Compute the parameter strings list.
437 :     my @parmStrings;
438 :     my $parms = $self->{parms};
439 :     my $parmsCount = scalar @$parms;
440 :     for (my $i = 0; $i < $parmsCount; $i++) {
441 :     if (defined $parameters[$i]) {
442 :     push @parmStrings, '$' . $parameters[$i];
443 :     } else {
444 :     push @parmStrings, Quotify($parms->[$i]);
445 :     }
446 :     }
447 :     # Clean up and quote the object name string.
448 :     my $quotedObjectNameString = qq("$self->{objects}");
449 :     $quotedObjectNameString =~ s/\s+/ /;
450 :     # Quote the filter string.
451 :     my $quotedFilterString = Quotify($self->{filterString});
452 :     # The result from the Get call depends on the type: a list for
453 :     # GetAll, a scalar for Get.
454 :     my $getResultName = ($codeStyle eq 'Get' ? '$qh' : '@resultRows');
455 :     # Build the Get. It's multiple lines, so we need to compute how far to
456 :     # indent the secondary lines. In addition, we need to decide here whether
457 :     # we're doing a Get or a GetAll.
458 :     my $buffer = "my $getResultName = $dbObjectName->$codeStyle(";
459 :     my $continueTab = " " x length($buffer);
460 :     # Now set up the buffer so that it has the Get call and the object
461 :     # name string. This is the minimum content for the first line.
462 :     $buffer .= "$quotedObjectNameString, ";
463 :     # Now we break the rest of the statement into pieces.
464 :     my @pieces = "$quotedFilterString, ";
465 :     if (! @parmStrings) {
466 :     push @pieces, "[]";
467 :     } else {
468 :     push @pieces, "[" . shift(@parmStrings);
469 :     push @pieces, @parmStrings;
470 :     $pieces[$#pieces] .= "]";
471 :     }
472 :     # If this is a GetAll, the field names go in here, too.
473 :     if ($codeStyle eq 'GetAll') {
474 :     # First, we need to put a comma at the end of the last parameter.
475 :     $pieces[$#pieces] .= ", ";
476 :     # Now, we create a list of the field names. We use the qw
477 :     # trick to make them into a list.
478 :     my @quotedFields = map { $_->{name} } @$fields;
479 :     $quotedFields[0] = "[qw(" . $quotedFields[0];
480 :     $quotedFields[$#quotedFields] .= ")]";
481 :     for (my $i = 0; $i < $#quotedFields; $i++) {
482 :     $quotedFields[$i] .= " ";
483 :     }
484 :     push @pieces, @quotedFields;
485 :     }
486 :     # Put the statement terminator on the last piece.
487 :     $pieces[$#pieces] .= ");";
488 :     # Loop through the pieces, building the code lines.
489 :     for my $piece (@pieces) {
490 :     if (length($buffer) + length($piece) > 80) {
491 :     push @codeLines, $buffer;
492 :     $buffer = $continueTab;
493 :     }
494 :     $buffer .= $piece;
495 :     }
496 :     # Finish the Get statement. The buffer is never empty after the above
497 :     # loop.
498 :     push @codeLines, $buffer;
499 :     # The rest of this is only necessary for the Get-style.
500 :     if ($codeStyle eq 'Get') {
501 :     # Build the fetch loop.
502 :     push @codeLines, "while (my \$resultRow = \$qh->Fetch()) {";
503 :     # Extract each field value.
504 :     for my $field (@$fields) {
505 :     # Get the field name.
506 :     my $fieldName = $field->{name};
507 :     # Convert the field name to a camel-cased variable name.
508 :     my @pieces = split /[^a-z]+/, lc $fieldName;
509 :     my $varName = shift @pieces;
510 :     $varName .= join("", map { ucfirst $_ } @pieces);
511 :     # We'll put the retrieval statement in here.
512 :     my $statement;
513 :     # Is this a primary field or a secondary field?
514 :     if ($field->{secondary}) {
515 :     # It's a secondary field, so we get a list of values.
516 :     $statement = "my \@$varName = \$resultRow->Value('$fieldName');";
517 :     } else {
518 :     # It's primary, so we get a single value.
519 :     $statement = "my \$$varName = \$resultRow->PrimaryValue('$fieldName');";
520 :     }
521 :     # If this field is complex, add a comment about the field type.
522 :     my $type = $field->{type}->objectType();
523 :     if (defined $type) {
524 :     $statement .= " # $type object";
525 :     }
526 :     # Output the statement.
527 :     push @codeLines, "$tab$statement";
528 :     }
529 :     # Close the fetch loop.
530 :     push @codeLines, "$tab##TODO: Process data";
531 :     push @codeLines, "}";
532 :     }
533 :     # Return the result.
534 :     return join("\n", @codeLines, "");
535 :     }
536 :    
537 :     =head3 Summary
538 :    
539 :     my $statsHtml = $eq->Summary();
540 :    
541 :     Return an HTML display of the statistics and messages for this query.
542 :    
543 :     =cut
544 :    
545 :     sub Summary {
546 :     # Get the parameters.
547 :     my ($self) = @_;
548 :     # We'll accumulate HTML in here.
549 :     my $retVal = "";
550 :     # Get the statistics object.
551 :     my $stats = $self->{stats};
552 :     # Extract the messages.
553 :     my @messages = $stats->Messages();
554 :     # If there are messages, we need to display them.
555 :     if (scalar @messages) {
556 :     $retVal .= CGI::p("Errors and warnings for this query.") .
557 :     CGI::ul(map { CGI::li(CGI::escapeHTML($_)) } @messages);
558 :     }
559 :     # Now we display the statistics in alphabetical order, using a table.
560 :     my $statMap = $stats->Map();
561 :     my @keys = sort { Tracer::Cmp($a, $b) } keys %$statMap;
562 :     $retVal .= CGI::h3("Query Statistics");
563 :     $retVal .= CGI::table(
564 :     map { CGI::Tr(CGI::th($_), CGI::td({ align => 'right' },
565 :     $statMap->{$_})) } @keys);
566 :     # Return the result.
567 :     return $retVal;
568 :     }
569 :    
570 :    
571 :     =head2 Internal Methods
572 :    
573 :     =head3 Quotify
574 :    
575 :     my $quoted = ERDBQueryConsole::Quotify($string);
576 :    
577 :     Convert the input string to a PERL string constant. Internal single
578 :     quotes will be escaped, and the entire string will be surrounded by
579 :     single quotes.
580 :    
581 :     =over 4
582 :    
583 :     =item string
584 :    
585 :     String to be quoted.
586 :    
587 :     =item RETURN
588 :    
589 :     Returns the string in a format suitable for encoding as a PERL
590 :     string literal.
591 :    
592 :     =back
593 :    
594 :     =cut
595 :    
596 :     sub Quotify {
597 :     # Get the parameters.
598 :     my ($string) = @_;
599 :     # Declare the return variable.
600 :     my $retVal = $string;
601 :     # Quote the internal quotes.
602 :     $retVal =~ s/'/\\'/g;
603 :     # Literalize the new-lines.
604 :     $retVal =~ s/\n/\\n/g;
605 :     # Return the result.
606 :     return "'$retVal'";
607 :     }
608 :    
609 :     =head3 Error
610 :    
611 :     $eq->Error($message);
612 :    
613 :     Record an error message. Error messages are kept in a list attached to
614 :     this object.
615 :    
616 :     =over 4
617 :    
618 :     =item message
619 :    
620 :     Message to add to the error list.
621 :    
622 :     =back
623 :    
624 :     =cut
625 :    
626 :     sub Error {
627 :     # Get the parameters.
628 :     my ($self, $message) = @_;
629 :     # Add the error message to our statistics object.
630 :     $self->{stats}->AddMessage($message);
631 :     # Record the error as a statistic.
632 :     $self->AddStat(errors => 1);
633 :     }
634 :    
635 :     =head3 AddStat
636 :    
637 :     $eq->AddStat($statName => $value);
638 :    
639 :     Add the specified value to the named statistic.
640 :    
641 :     =over 4
642 :    
643 :     =item statName
644 :    
645 :     Name of the relevant statistic.
646 :    
647 :     =item value
648 :    
649 :     Value to add to the named statistic counter.
650 :    
651 :     =back
652 :    
653 :     =cut
654 :    
655 :     sub AddStat {
656 :     # Get the parameters.
657 :     my ($self, $statName, $value) = @_;
658 :     $self->{stats}->Add($statName => $value);
659 :     }
660 :    
661 :     =head3 Clear
662 :    
663 :     $eq->Clear();
664 :    
665 :     Initialize this object for a new query.
666 :    
667 :     =cut
668 :    
669 :     sub Clear {
670 :     # Get the parameters.
671 :     my ($self) = @_;
672 :     # Empty the field list.
673 :     $self->{fields} = [];
674 :     # Erase the statistics.
675 :     $self->{stats} = Stats->new(qw(records fields errors));
676 :     # Denote we have no query attached.
677 :     $self->{query} = undef;
678 :     }
679 :    
680 :    
681 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3