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

Annotation of /Sprout/ERDBQueryConsole.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (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 :     # Start the web page.
194 :     TWiki::Plugins::NmpdrPlugin::StartPage("ERDB Query Output", []);
195 :     # Count the parameters.
196 :     my $suppliedParms = scalar(@$parms);
197 :     Trace("$suppliedParms parameters found.") if T(3);
198 :     # Verify the various parameters.
199 :     if (! $objects) {
200 :     $self->Error("No object list specified. Query aborted.");
201 :     } elsif (! $fields) {
202 :     $self->Error("No output fields specified. Query aborted.");
203 :     } elsif ($parmCount > $suppliedParms) {
204 :     $self->Error("You have $parmCount parameter marks but only $suppliedParms " .
205 :     "Parameters. Insure each parameter is on a separate line in " .
206 :     "the parameters box and that you don't have any extra question " .
207 :     "marks (?) in the Filter String.");
208 :     } elsif ($parmCount < $suppliedParms) {
209 :     $self->Error("You have $suppliedParms Parameters but there are only " .
210 :     "$parmCount parameter marks in the Filter String.")
211 :     } else {
212 :     # Now we can do the query. First, get the database object.
213 :     my $db = $self->{erdb};
214 :     # Parse the object name list.
215 :     my @nameErrors = $db->CheckObjectNames($objects);
216 :     if (@nameErrors) {
217 :     # Here there were errors in the object name string.
218 :     for my $nameError (@nameErrors) {
219 :     $self->Error($nameError);
220 :     }
221 :     $self->Error("Errors were found in the Object Names.");
222 :     } else {
223 :     # Check to see if we need to limit this query.
224 :     my $limitClause = "";
225 :     if (! $self->{secure}) {
226 :     # We do. Check for an existing limit.
227 :     if ($filterString =~ /(.+)\s+LIMIT\s+(\d+)(.*)/) {
228 :     # Fix it if it's too big.
229 :     if ($2 >= $FIG_Config::query_limit) {
230 :     $filterString = "$1 LIMIT $FIG_Config::query_limit$3";
231 :     }
232 :     } else {
233 :     # No limit present, so add one.
234 :     $limitClause = " LIMIT $FIG_Config::query_limit";
235 :     }
236 :     } else {
237 :     # Privileged users can request a different limit. Only use it
238 :     # if there is not already a limit in the filter clause.
239 :     if ($limitNumber && $filterString !~ /\sLIMIT\s/) {
240 :     $limitClause = " LIMIT $limitNumber";
241 :     Trace("Limit clause for $limitNumber rows added to query.") if T(2);
242 :     }
243 :     }
244 :     # Now we need to find things out about the fields. For each one,
245 :     # we need a column name and a cell format. To get that, we
246 :     # start the query and analyze the fields.
247 :     Trace("Preparing query.") if T(3);
248 :     my $query = eval('$db->Prepare($objects, "$filterString$limitClause", $parms)');
249 :     if ($@) {
250 :     # Here the query preparation failed for some reason. This is usually an
251 :     # SQL syntax error.
252 :     $self->Error("QUERY ERROR: $@");
253 :     } else {
254 :     Trace("Parsing field list.") if T(3);
255 :     # We need to get the necessary data for each field in the field list.
256 :     # This will be set to TRUE if a valid field is found.
257 :     my $found;
258 :     # Now loop through the field names.
259 :     for my $field (@$fields) {
260 :     Trace("Processing field name \"$field\".") if T(3);
261 :     # Get the data for this field.
262 :     my ($objectName, $fieldName, $type) = $query->CheckFieldName($field);
263 :     if (! defined $objectName) {
264 :     # Here the field specification had an invalid format.
265 :     $self->Error("Field specifier \"$field\" has an invalid format.");
266 :     } elsif (! defined $fieldName) {
267 :     # Here the object name was invalid. That generates a warning.
268 :     $self->Error("Object name \"$objectName\" not found in query.");
269 :     } elsif (! defined $type) {
270 :     # Here the field name was invalid. That is also a warning.
271 :     $self->Error("Field \"$fieldName\" not found in $objectName.");
272 :     } else {
273 :     # Here the field name is okay. Save its data.
274 :     push @{$self->{fields}},
275 :     { name => $field, type => $type,
276 :     secondary => $db->IsSecondary($fieldName, $objectName)
277 :     };
278 :     # Count the field.
279 :     $self->AddStat(fields => 1);
280 :     $found = 1;
281 :     }
282 :     }
283 :     # Insure we have at least one valid field.
284 :     if (! $found) {
285 :     $self->Error("No valid field names were specified for this query.");
286 :     } else {
287 :     # We do, so save the query and its parameters.
288 :     $self->{query} = $query;
289 :     $self->{parms} = $parms;
290 :     $self->{objects} = $objects;
291 :     $self->{filterString} = $filterString;
292 :     }
293 :     }
294 :     }
295 :     }
296 :     # Return TRUE if no errors were detected.
297 :     return defined $self->{query};
298 :     }
299 :    
300 :     =head3 Headers
301 :    
302 :     my @columnData = $eq->Headers();
303 :    
304 :     Return the header information for each column of the output. The header
305 :     information is returned as a list of 2-tuples. For each column, the
306 :     2-tuple includes the column caption and the alignment (C<left>, C<right>,
307 :     or C<center>).
308 :    
309 :     =cut
310 :    
311 :     sub Headers {
312 :     # Get the parameters.
313 :     my ($self) = @_;
314 :     # Declare the return variable.
315 :     my @retVal;
316 :     # Insure we have fields. If we don't, the query will be treated as
317 :     # having 0 output columns: we'll return an empty list.
318 :     if (defined $self->{fields}) {
319 :     # We have something, so loop through the fields.
320 :     for my $field (@{$self->{fields}}) {
321 :     # Compute the alignment.
322 :     my $align = $field->{type}->align();
323 :     # Push it into the result list along with the field name.
324 :     push @retVal, [$field->{name}, $align];
325 :     }
326 :     }
327 :     # Return the result.
328 :     return @retVal;
329 :     }
330 :    
331 :     =head3 GetRow
332 :    
333 :     my @items = $eq->GetRow();
334 :    
335 :     Get the next row of data from the query. Each row will consist of a list
336 :     of HTML strings, one per result column, in the same order the field names
337 :     appeared when the query was submitted.
338 :    
339 :     If the query is complete, an empty list will be returned.
340 :    
341 :     =cut
342 :    
343 :     sub GetRow {
344 :     # Get the parameters.
345 :     my ($self) = @_;
346 :     # Declare the return variable.
347 :     my @retVal;
348 :     # Only proceed if we have an active query.
349 :     if (defined $self->{query}) {
350 :     # We do, so try to get the next record. Note we accumulate the
351 :     # time spent and protect from errors.
352 :    
353 :     my $start = time();
354 :     my $record = $self->{query}->Fetch();
355 :     $self->AddStat(duration => time() - $start);
356 :     # Only proceed if a record was found.
357 :     if (defined $record) {
358 :     # Now we have the data for this row, and it's time to
359 :     # stuff it into the return list. Loop through the fields.
360 :     for my $field (@{$self->{fields}}) {
361 :     # Get the values for this field.
362 :     my @values = $record->Value($field->{name});
363 :     $self->AddStat(values => scalar(@values));
364 :     # Get the field type.
365 :     my $type = $field->{type};
366 :     # Convert the values to HTML and string them together.
367 :     my $cell = join("<br />", map { $type->html($_) } @values);
368 :     # Put the result into the output list.
369 :     push @retVal, $cell;
370 :     }
371 :     }
372 :     }
373 :     # Return the result.
374 :     return @retVal;
375 :     }
376 :    
377 :     =head3 GetCode
378 :    
379 :     my $codeString = $eq->GetCode($dbVarName, $codeStyle, @parameters);
380 :    
381 :     Return the PERL code to perform the query submitted to this console.
382 :    
383 :     =over 4
384 :    
385 :     =item dbVarName
386 :    
387 :     Name to give to the variable containing the database object.
388 :    
389 :     =item codeStyle
390 :    
391 :     Coding style to use: C<Get> for a get loop, C<GetAll> for a single get-all
392 :     statement.
393 :    
394 :     =item parameters
395 :    
396 :     List of parameter names. If a parameter name is a string, then the
397 :     corresponding parameter will be encoded as a variable with the name
398 :     given by the string. If a parameter name is an undefined value, the
399 :     parameter value will be encoded as a constant.
400 :    
401 :     =item RETURN
402 :    
403 :     Returns a string containing the PERL code to duplicate the incoming
404 :     query.
405 :    
406 :     =back
407 :    
408 :     =cut
409 :    
410 :     sub GetCode {
411 :     # Get the parameters.
412 :     my ($self, $dbVarName, $codeStyle, @parameters) = @_;
413 :     # We'll create lines of PERL code in here.
414 :     my @codeLines;
415 :     # We'll use this constant for tabbing purposes.
416 :     my $tab = " " x 4;
417 :     # Compute the name of the database object.
418 :     my $dbObjectName = '$' . $dbVarName;
419 :     # We start with some USE statements.
420 :     push @codeLines, "use ERDB;",
421 :     "use Tracer;";
422 :     # Get the field list. We'll be using it a lot.
423 :     my $fields = $self->{fields};
424 :     # Add "use" statements for all the field types. We build a hash
425 :     # to prevent duplicates.
426 :     my %uses;
427 :     for my $field (@$fields) {
428 :     my $type = $field->{type}->objectType();
429 :     if ($type) {
430 :     $uses{$type} = 1;
431 :     }
432 :     }
433 :     push @codeLines, map { "use $_;" } sort keys %uses;
434 :     # Now create the database object.
435 :     my $dbType = ref $self->{erdb};
436 :     push @codeLines, "",
437 :     "my $dbObjectName = ERDB::GetDatabase('$dbType');",
438 :     "";
439 :     # Compute the parameter strings list.
440 :     my @parmStrings;
441 :     my $parms = $self->{parms};
442 :     my $parmsCount = scalar @$parms;
443 :     for (my $i = 0; $i < $parmsCount; $i++) {
444 :     if (defined $parameters[$i]) {
445 :     push @parmStrings, '$' . $parameters[$i];
446 :     } else {
447 :     push @parmStrings, Quotify($parms->[$i]);
448 :     }
449 :     }
450 :     # Clean up and quote the object name string.
451 :     my $quotedObjectNameString = qq("$self->{objects}");
452 :     $quotedObjectNameString =~ s/\s+/ /;
453 :     # Quote the filter string.
454 :     my $quotedFilterString = Quotify($self->{filterString});
455 :     # The result from the Get call depends on the type: a list for
456 :     # GetAll, a scalar for Get.
457 :     my $getResultName = ($codeStyle eq 'Get' ? '$qh' : '@resultRows');
458 :     # Build the Get. It's multiple lines, so we need to compute how far to
459 :     # indent the secondary lines. In addition, we need to decide here whether
460 :     # we're doing a Get or a GetAll.
461 :     my $buffer = "my $getResultName = $dbObjectName->$codeStyle(";
462 :     my $continueTab = " " x length($buffer);
463 :     # Now set up the buffer so that it has the Get call and the object
464 :     # name string. This is the minimum content for the first line.
465 :     $buffer .= "$quotedObjectNameString, ";
466 :     # Now we break the rest of the statement into pieces.
467 :     my @pieces = "$quotedFilterString, ";
468 :     if (! @parmStrings) {
469 :     push @pieces, "[]";
470 :     } else {
471 :     push @pieces, "[" . shift(@parmStrings);
472 :     push @pieces, @parmStrings;
473 :     $pieces[$#pieces] .= "]";
474 :     }
475 :     # If this is a GetAll, the field names go in here, too.
476 :     if ($codeStyle eq 'GetAll') {
477 :     # First, we need to put a comma at the end of the last parameter.
478 :     $pieces[$#pieces] .= ", ";
479 :     # Now, we create a list of the field names. We use the qw
480 :     # trick to make them into a list.
481 :     my @quotedFields = map { $_->{name} } @$fields;
482 :     $quotedFields[0] = "[qw(" . $quotedFields[0];
483 :     $quotedFields[$#quotedFields] .= ")]";
484 :     for (my $i = 0; $i < $#quotedFields; $i++) {
485 :     $quotedFields[$i] .= " ";
486 :     }
487 :     push @pieces, @quotedFields;
488 :     }
489 :     # Put the statement terminator on the last piece.
490 :     $pieces[$#pieces] .= ");";
491 :     # Loop through the pieces, building the code lines.
492 :     for my $piece (@pieces) {
493 :     if (length($buffer) + length($piece) > 80) {
494 :     push @codeLines, $buffer;
495 :     $buffer = $continueTab;
496 :     }
497 :     $buffer .= $piece;
498 :     }
499 :     # Finish the Get statement. The buffer is never empty after the above
500 :     # loop.
501 :     push @codeLines, $buffer;
502 :     # The rest of this is only necessary for the Get-style.
503 :     if ($codeStyle eq 'Get') {
504 :     # Build the fetch loop.
505 :     push @codeLines, "while (my \$resultRow = \$qh->Fetch()) {";
506 :     # Extract each field value.
507 :     for my $field (@$fields) {
508 :     # Get the field name.
509 :     my $fieldName = $field->{name};
510 :     # Convert the field name to a camel-cased variable name.
511 :     my @pieces = split /[^a-z]+/, lc $fieldName;
512 :     my $varName = shift @pieces;
513 :     $varName .= join("", map { ucfirst $_ } @pieces);
514 :     # We'll put the retrieval statement in here.
515 :     my $statement;
516 :     # Is this a primary field or a secondary field?
517 :     if ($field->{secondary}) {
518 :     # It's a secondary field, so we get a list of values.
519 :     $statement = "my \@$varName = \$resultRow->Value('$fieldName');";
520 :     } else {
521 :     # It's primary, so we get a single value.
522 :     $statement = "my \$$varName = \$resultRow->PrimaryValue('$fieldName');";
523 :     }
524 :     # If this field is complex, add a comment about the field type.
525 :     my $type = $field->{type}->objectType();
526 :     if (defined $type) {
527 :     $statement .= " # $type object";
528 :     }
529 :     # Output the statement.
530 :     push @codeLines, "$tab$statement";
531 :     }
532 :     # Close the fetch loop.
533 :     push @codeLines, "$tab##TODO: Process data";
534 :     push @codeLines, "}";
535 :     }
536 :     # Return the result.
537 :     return join("\n", @codeLines, "");
538 :     }
539 :    
540 :     =head3 Summary
541 :    
542 :     my $statsHtml = $eq->Summary();
543 :    
544 :     Return an HTML display of the statistics and messages for this query.
545 :    
546 :     =cut
547 :    
548 :     sub Summary {
549 :     # Get the parameters.
550 :     my ($self) = @_;
551 :     # We'll accumulate HTML in here.
552 :     my $retVal = "";
553 :     # Get the statistics object.
554 :     my $stats = $self->{stats};
555 :     # Extract the messages.
556 :     my @messages = $stats->Messages();
557 :     # If there are messages, we need to display them.
558 :     if (scalar @messages) {
559 :     $retVal .= CGI::p("Errors and warnings for this query.") .
560 :     CGI::ul(map { CGI::li(CGI::escapeHTML($_)) } @messages);
561 :     }
562 :     # Now we display the statistics in alphabetical order, using a table.
563 :     my $statMap = $stats->Map();
564 :     my @keys = sort { Tracer::Cmp($a, $b) } keys %$statMap;
565 :     $retVal .= CGI::h3("Query Statistics");
566 :     $retVal .= CGI::table(
567 :     map { CGI::Tr(CGI::th($_), CGI::td({ align => 'right' },
568 :     $statMap->{$_})) } @keys);
569 :     # Return the result.
570 :     return $retVal;
571 :     }
572 :    
573 :    
574 :     =head2 Internal Methods
575 :    
576 :     =head3 Quotify
577 :    
578 :     my $quoted = ERDBQueryConsole::Quotify($string);
579 :    
580 :     Convert the input string to a PERL string constant. Internal single
581 :     quotes will be escaped, and the entire string will be surrounded by
582 :     single quotes.
583 :    
584 :     =over 4
585 :    
586 :     =item string
587 :    
588 :     String to be quoted.
589 :    
590 :     =item RETURN
591 :    
592 :     Returns the string in a format suitable for encoding as a PERL
593 :     string literal.
594 :    
595 :     =back
596 :    
597 :     =cut
598 :    
599 :     sub Quotify {
600 :     # Get the parameters.
601 :     my ($string) = @_;
602 :     # Declare the return variable.
603 :     my $retVal = $string;
604 :     # Quote the internal quotes.
605 :     $retVal =~ s/'/\\'/g;
606 :     # Literalize the new-lines.
607 :     $retVal =~ s/\n/\\n/g;
608 :     # Return the result.
609 :     return "'$retVal'";
610 :     }
611 :    
612 :     =head3 Error
613 :    
614 :     $eq->Error($message);
615 :    
616 :     Record an error message. Error messages are kept in a list attached to
617 :     this object.
618 :    
619 :     =over 4
620 :    
621 :     =item message
622 :    
623 :     Message to add to the error list.
624 :    
625 :     =back
626 :    
627 :     =cut
628 :    
629 :     sub Error {
630 :     # Get the parameters.
631 :     my ($self, $message) = @_;
632 :     # Add the error message to our statistics object.
633 :     $self->{stats}->AddMessage($message);
634 :     # Record the error as a statistic.
635 :     $self->AddStat(errors => 1);
636 :     }
637 :    
638 :     =head3 AddStat
639 :    
640 :     $eq->AddStat($statName => $value);
641 :    
642 :     Add the specified value to the named statistic.
643 :    
644 :     =over 4
645 :    
646 :     =item statName
647 :    
648 :     Name of the relevant statistic.
649 :    
650 :     =item value
651 :    
652 :     Value to add to the named statistic counter.
653 :    
654 :     =back
655 :    
656 :     =cut
657 :    
658 :     sub AddStat {
659 :     # Get the parameters.
660 :     my ($self, $statName, $value) = @_;
661 :     $self->{stats}->Add($statName => $value);
662 :     }
663 :    
664 :     =head3 Clear
665 :    
666 :     $eq->Clear();
667 :    
668 :     Initialize this object for a new query.
669 :    
670 :     =cut
671 :    
672 :     sub Clear {
673 :     # Get the parameters.
674 :     my ($self) = @_;
675 :     # Empty the field list.
676 :     $self->{fields} = [];
677 :     # Erase the statistics.
678 :     $self->{stats} = Stats->new(qw(records fields errors));
679 :     # Denote we have no query attached.
680 :     $self->{query} = undef;
681 :     }
682 :    
683 :    
684 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3