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

Annotation of /Sprout/SearchHelper.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : parrello 1.1 #!/usr/bin/perl -w
2 :    
3 :     package SearchHelper;
4 :    
5 :     use strict;
6 :     use Tracer;
7 :     use PageBuilder;
8 :     use Digest::MD5;
9 :     use File::Basename;
10 :     use File::Path;
11 :     use File::stat;
12 :     use LWP::UserAgent;
13 : parrello 1.34 use FIGRules;
14 : parrello 1.1 use Sprout;
15 :     use SFXlate;
16 :     use FIGRules;
17 :     use HTML;
18 :     use BasicLocation;
19 : parrello 1.3 use URI::Escape;
20 :     use PageBuilder;
21 : parrello 1.34 use AliasAnalysis;
22 :     use FreezeThaw qw(freeze thaw);
23 : parrello 1.1
24 :     =head1 Search Helper Base Class
25 :    
26 :     =head2 Introduction
27 :    
28 :     The search helper is a base class for all search objects. It has methods for performing
29 :     all the common tasks required to build and manage a search cache. The subclass must
30 :     provide methods for generating and processing search forms. The base class has the
31 :     following object fields.
32 :    
33 :     =over 4
34 :    
35 :     =item cols
36 :    
37 :     Reference to a list of column header descriptions. If undefined, then the session cache
38 :     file has been opened but nothing has been written to it.
39 :    
40 :     =item fileHandle
41 :    
42 :     File handle for the session cache file.
43 :    
44 :     =item query
45 :    
46 :     CGI query object, which includes the search parameters and the various
47 :     session status variables kept between requests from the user.
48 :    
49 :     =item type
50 :    
51 :     Session type: C<old> if there is an existing cache file from which we are
52 :     displaying search results, or C<new> if the cache file needs to be built.
53 :    
54 :     =item class
55 :    
56 :     Name of the search helper class as it would appear in the CGI query object
57 :     (i.e. without the C<SH> prefix.
58 :    
59 :     =item sprout
60 :    
61 :     Sprout object for accessing the database.
62 :    
63 :     =item message
64 :    
65 :     Message to display if an error has been detected.
66 :    
67 :     =item orgs
68 :    
69 : parrello 1.34 Reference to a hash mapping genome IDs to organism data. (Used to
70 :     improve performance.)
71 : parrello 1.1
72 :     =item name
73 :    
74 :     Name to use for this object's form.
75 :    
76 :     =item scriptQueue
77 :    
78 :     List of JavaScript statements to be executed after the form is closed.
79 :    
80 : parrello 1.3 =item genomeHash
81 :    
82 :     Cache of the genome group hash used to build genome selection controls.
83 :    
84 :     =item genomeParms
85 :    
86 :     List of the parameters that are used to select multiple genomes.
87 :    
88 : parrello 1.1 =back
89 :    
90 : parrello 1.2 =head2 Adding a new Search Tool
91 :    
92 :     To add a new search tool to the system, you must
93 :    
94 :     =over 4
95 :    
96 :     =item 1
97 :    
98 :     Choose a class name for your search tool.
99 :    
100 :     =item 2
101 :    
102 :     Create a new subclass of this object and implement each of the virtual methods. The
103 : parrello 1.34 name of the subclass must be C<SH>I<className>, where I<className> is the
104 :     type of search.
105 : parrello 1.2
106 :     =item 3
107 :    
108 :     Create an include file among the web server pages that describes how to use
109 :     the search tool. The include file must be in the B<includes> directory, and
110 :     its name must be C<SearchHelp_>I<className>C<.inc>.
111 :    
112 :     =item 4
113 :    
114 : parrello 1.34 If your search produces a result for which a helper does not exist, you
115 :     must create a new subclass of B<ResultHelper>. Its name must be
116 :     C<RH>I<className>, where I<className> is the type of result.
117 : parrello 1.2
118 :     =back
119 :    
120 :     =head3 Building a Search Form
121 :    
122 :     All search forms are three-column tables. In general, you want one form
123 :     variable per table row. The first column should contain the label and
124 :     the second should contain the form control for specifying the variable
125 :     value. If the control is wide, you should use C<colspan="2"> to give it
126 :     extra room. B<Do not> specify a width in any of your table cells, as
127 :     width management is handled by this class.
128 :    
129 :     The general code for creating the form should be
130 :    
131 :     sub Form {
132 :     my ($self) = @_;
133 :     # Get the CGI object.
134 :     my $cgi = @self->Q();
135 :     # Start the form.
136 :     my $retVal = $self->FormStart("form title");
137 :     # Assemble the table rows.
138 :     my @rows = ();
139 :     ... push table row Html into @rows ...
140 :     push @rows, $self->SubmitRow();
141 :     ... push more Html into @rows ...
142 :     # Build the table from the rows.
143 :     $retVal .= $self->MakeTable(\@rows);
144 :     # Close the form.
145 :     $retVal .= $self->FormEnd();
146 :     # Return the form Html.
147 :     return $retVal;
148 :     }
149 :    
150 :     Several helper methods are provided for particular purposes.
151 :    
152 : parrello 1.3 L</NmpdrGenomeMenu> generates a control for selecting one or more genomes. Use
153 :     L</GetGenomes> to retrieve all the genomes passed in for a specified parameter
154 :     name. Note that as an assist to people working with GET-style links, if no
155 :     genomes are specified and the incoming request style is GET, all genomes will
156 :     be returned.
157 : parrello 1.2
158 :     L</QueueFormScript> allows you to queue JavaScript statements for execution
159 :     after the form is fully generated. If you are using very complicated
160 :     form controls, the L</QueueFormScript> method allows you to perform
161 :     JavaScript initialization. The L</NmpdrGenomeMenu> control uses this
162 :     facility to display a list of the pre-selected genomes.
163 :    
164 :     Finally, when generating the code for your controls, be sure to use any incoming
165 :     query parameters as default values so that the search request is persistent.
166 :    
167 :     =head3 Finding Search Results
168 :    
169 : parrello 1.34 The L</Find> method is used to create the search results. The basic code
170 :     structure would work as follows.
171 : parrello 1.2
172 :     sub Find {
173 :     my ($self) = @_;
174 :     # Get the CGI and Sprout objects.
175 :     my $cgi = $self->Q();
176 :     my $sprout = $self->DB();
177 :     # Declare the return variable. If it remains undefined, the caller will
178 :     # know that an error occurred.
179 :     my $retVal;
180 :     ... validate the parameters ...
181 :     if (... invalid parameters...) {
182 :     $self->SetMessage(...appropriate message...);
183 : parrello 1.34 } else {
184 :     # Determine the result type.
185 :     my $rhelp = SearchHelper::GetHelper($self, RH => $resultType);
186 :     # Specify the columns.
187 :     $self->DefaultColumns($rhelp);
188 :     # You may want to add extra columns. $name is the column name and
189 :     # $loc is its location. The other parameters take their names from the
190 :     # corresponding column methods.
191 :     $rhelp->AddExtraColumn($name => $loc, style => $style, download => $flag,
192 :     title => $title);
193 :     # Some searches require optional columns that are configured by the
194 :     # user or by the search query itself. There are some special methods
195 :     # for this in the result helpers, but there's also the direct approach
196 :     # shown below.
197 :     $rhelp->AddOptionalColumn($name => $loc);
198 : parrello 1.2 # Initialize the session file.
199 : parrello 1.34 $self->OpenSession($rhelp);
200 : parrello 1.2 # Initialize the result counter.
201 :     $retVal = 0;
202 : parrello 1.34 ... set up to loop through the results ...
203 :     while (...more results...) {
204 :     ...compute extra columns and call PutExtraColumns...
205 :     $rhelp->PutData($sortKey, $objectID, $record);
206 :     $retVal++;
207 : parrello 1.2 }
208 : parrello 1.9 # Close the session file.
209 :     $self->CloseSession();
210 : parrello 1.2 }
211 :     # Return the result count.
212 :     return $retVal;
213 :     }
214 :    
215 :     A Find method is of course much more complicated than generating a form, and there
216 : parrello 1.34 are variations on the above theme.
217 : parrello 1.2
218 : parrello 1.28 In addition to the finding and filtering, it is necessary to send status messages
219 :     to the output so that the user does not get bored waiting for results. The L</PrintLine>
220 :     method performs this function. The single parameter should be text to be
221 :     output to the browser. In general, you'll invoke it as follows.
222 :    
223 :     $self->PrintLine("...my message text...<br />");
224 :    
225 :     The break tag is optional. When the Find method gets control, a paragraph will
226 :     have been started so that everything is XHTML-compliant.
227 :    
228 : parrello 1.2 The L</Find> method must return C<undef> if the search parameters are invalid. If this
229 :     is the case, then a message describing the problem should be passed to the framework
230 :     by calling L</SetMessage>. If the parameters are valid, then the method must return
231 :     the number of items found.
232 :    
233 : parrello 1.1 =cut
234 :    
235 :     # This counter is used to insure every form on the page has a unique name.
236 :     my $formCount = 0;
237 : parrello 1.16 # This counter is used to generate unique DIV IDs.
238 :     my $divCount = 0;
239 : parrello 1.1
240 :     =head2 Public Methods
241 :    
242 :     =head3 new
243 :    
244 : parrello 1.28 C<< my $shelp = SearchHelper->new($cgi); >>
245 : parrello 1.1
246 :     Construct a new SearchHelper object.
247 :    
248 :     =over 4
249 :    
250 : parrello 1.19 =item cgi
251 : parrello 1.1
252 :     The CGI query object for the current script.
253 :    
254 :     =back
255 :    
256 :     =cut
257 :    
258 :     sub new {
259 :     # Get the parameters.
260 : parrello 1.19 my ($class, $cgi) = @_;
261 : parrello 1.1 # Check for a session ID.
262 : parrello 1.19 my $session_id = $cgi->param("SessionID");
263 : parrello 1.1 my $type = "old";
264 :     if (! $session_id) {
265 : parrello 1.26 Trace("No session ID found.") if T(3);
266 : parrello 1.1 # Here we're starting a new session. We create the session ID and
267 :     # store it in the query object.
268 : parrello 1.34 $session_id = FIGRules::NewSessionID();
269 :     Trace("New session ID is $session_id.") if T(3);
270 : parrello 1.1 $type = "new";
271 : parrello 1.19 $cgi->param(-name => 'SessionID', -value => $session_id);
272 : parrello 1.26 } else {
273 :     Trace("Session ID is $session_id.") if T(3);
274 : parrello 1.1 }
275 : parrello 1.34 Trace("Computing subclass.") if T(3);
276 : parrello 1.1 # Compute the subclass name.
277 : parrello 1.19 my $subClass;
278 :     if ($class =~ /SH(.+)$/) {
279 :     # Here we have a real search class.
280 :     $subClass = $1;
281 :     } else {
282 :     # Here we have a bare class. The bare class cannot search, but it can
283 :     # process search results.
284 :     $subClass = 'SearchHelper';
285 :     }
286 : parrello 1.34 Trace("Subclass name is $subClass.") if T(3);
287 : parrello 1.1 # Insure everybody knows we're in Sprout mode.
288 : parrello 1.19 $cgi->param(-name => 'SPROUT', -value => 1);
289 : parrello 1.1 # Generate the form name.
290 :     my $formName = "$class$formCount";
291 :     $formCount++;
292 : parrello 1.34 Trace("Creating helper.") if T(3);
293 : parrello 1.1 # Create the shelp object. It contains the query object (with the session ID)
294 :     # as well as an indicator as to whether or not the session is new, plus the
295 : parrello 1.2 # class name and a placeholder for the Sprout object.
296 : parrello 1.1 my $retVal = {
297 : parrello 1.19 query => $cgi,
298 : parrello 1.1 type => $type,
299 :     class => $subClass,
300 : parrello 1.2 sprout => undef,
301 : parrello 1.1 orgs => {},
302 :     name => $formName,
303 :     scriptQueue => [],
304 : parrello 1.3 genomeList => undef,
305 :     genomeParms => [],
306 : parrello 1.1 };
307 :     # Bless and return it.
308 :     bless $retVal, $class;
309 :     return $retVal;
310 :     }
311 :    
312 :     =head3 Q
313 :    
314 :     C<< my $query = $shelp->Q(); >>
315 :    
316 :     Return the CGI query object.
317 :    
318 :     =cut
319 :    
320 :     sub Q {
321 :     # Get the parameters.
322 :     my ($self) = @_;
323 :     # Return the result.
324 :     return $self->{query};
325 :     }
326 :    
327 : parrello 1.9
328 :    
329 : parrello 1.1 =head3 DB
330 :    
331 :     C<< my $sprout = $shelp->DB(); >>
332 :    
333 :     Return the Sprout database object.
334 :    
335 :     =cut
336 :    
337 :     sub DB {
338 :     # Get the parameters.
339 :     my ($self) = @_;
340 : parrello 1.2 # Insure we have a database.
341 :     my $retVal = $self->{sprout};
342 :     if (! defined $retVal) {
343 :     $retVal = SFXlate->new_sprout_only();
344 :     $self->{sprout} = $retVal;
345 :     }
346 : parrello 1.1 # Return the result.
347 : parrello 1.2 return $retVal;
348 : parrello 1.1 }
349 :    
350 :     =head3 IsNew
351 :    
352 :     C<< my $flag = $shelp->IsNew(); >>
353 :    
354 :     Return TRUE if this is a new session, FALSE if this is an old session. An old
355 :     session already has search results ready to process.
356 :    
357 :     =cut
358 :    
359 :     sub IsNew {
360 :     # Get the parameters.
361 :     my ($self) = @_;
362 :     # Return the result.
363 :     return ($self->{type} eq 'new');
364 :     }
365 :    
366 :     =head3 ID
367 :    
368 :     C<< my $sessionID = $shelp->ID(); >>
369 :    
370 :     Return the current session ID.
371 :    
372 :     =cut
373 :    
374 :     sub ID {
375 :     # Get the parameters.
376 :     my ($self) = @_;
377 :     # Return the result.
378 :     return $self->Q()->param("SessionID");
379 :     }
380 :    
381 :     =head3 FormName
382 :    
383 :     C<< my $name = $shelp->FormName(); >>
384 :    
385 :     Return the name of the form this helper object will generate.
386 :    
387 :     =cut
388 :    
389 :     sub FormName {
390 :     # Get the parameters.
391 :     my ($self) = @_;
392 :     # Return the result.
393 :     return $self->{name};
394 :     }
395 :    
396 :     =head3 QueueFormScript
397 :    
398 :     C<< $shelp->QueueFormScript($statement); >>
399 :    
400 :     Add the specified statement to the queue of JavaScript statements that are to be
401 :     executed when the form has been fully defined. This is necessary because until
402 :     the closing </FORM> tag is emitted, the form elements cannot be referenced by
403 :     name. When generating the statement, you can refer to the variable C<thisForm>
404 :     in order to reference the form in progress. Thus,
405 :    
406 :     thisForm.simLimit.value = 1e-10;
407 :    
408 :     would set the value of the form element C<simLimit> in the current form to
409 :     C<1e-10>.
410 :    
411 :     =over 4
412 :    
413 :     =item statement
414 :    
415 :     JavaScript statement to be queued for execution after the form is built.
416 :     The trailing semi-colon is required. Theoretically, you could include
417 :     multiple statements separated by semi-colons, but one at a time works
418 :     just as well.
419 :    
420 :     =back
421 :    
422 :     =cut
423 :    
424 :     sub QueueFormScript {
425 :     # Get the parameters.
426 :     my ($self, $statement) = @_;
427 :     # Push the statement onto the script queue.
428 :     push @{$self->{scriptQueue}}, $statement;
429 :     }
430 :    
431 :     =head3 FormStart
432 :    
433 :     C<< my $html = $shelp->FormStart($title); >>
434 :    
435 :     Return the initial section of a form designed to perform another search of the
436 :     same type. The form header is included along with hidden fields to persist the
437 :     tracing, sprout status, and search class.
438 :    
439 :     A call to L</FormEnd> is required to close the form.
440 :    
441 :     =over 4
442 :    
443 :     =item title
444 :    
445 :     Title to be used for the form.
446 :    
447 :     =item RETURN
448 :    
449 :     Returns the initial HTML for the search form.
450 :    
451 :     =back
452 :    
453 :     =cut
454 :    
455 :     sub FormStart {
456 :     # Get the parameters.
457 :     my ($self, $title) = @_;
458 :     # Get the CGI object.
459 :     my $cgi = $self->Q();
460 : parrello 1.18 # Start the form. Note we use the override option on the Class value, in
461 :     # case the Advanced button was used.
462 : parrello 1.1 my $retVal = "<div class=\"search\">\n" .
463 :     $cgi->start_form(-method => 'POST',
464 :     -action => $cgi->url(-relative => 1),
465 :     -name => $self->FormName()) .
466 :     $cgi->hidden(-name => 'Class',
467 : parrello 1.18 -value => $self->{class},
468 :     -override => 1) .
469 : parrello 1.1 $cgi->hidden(-name => 'SPROUT',
470 :     -value => 1) .
471 : parrello 1.37 $cgi->h3("$title" . Hint($self->{class}, "Click here for more information."));
472 : parrello 1.1 # Put in an anchor tag in case there's a table of contents.
473 :     my $anchorName = $self->FormName();
474 :     $retVal .= "<a name=\"$anchorName\"></a>\n";
475 :     # Return the result.
476 :     return $retVal;
477 :     }
478 :    
479 :     =head3 FormEnd
480 :    
481 :     C<< my $htmlText = $shelp->FormEnd(); >>
482 :    
483 :     Return the HTML text for closing a search form. This closes both the C<form> and
484 :     C<div> tags.
485 :    
486 :     =cut
487 :    
488 :     sub FormEnd {
489 :     # Get the parameters.
490 :     my ($self) = @_;
491 :     # Declare the return variable, closing the form and the DIV block.
492 :     my $retVal = "</form></div>\n";
493 :     # Now we flush out the statement queue.
494 :     my @statements = @{$self->{scriptQueue}};
495 :     if (@statements > 0) {
496 :     # Switch to JavaScript and set the "thisForm" variable.
497 :     $retVal .= "<SCRIPT language=\"JavaScript\">\n" .
498 :     " thisForm = document.$self->{name};\n";
499 :     # Unroll the statements.
500 :     while (@statements > 0) {
501 :     my $statement = shift @statements;
502 :     $retVal .= " $statement\n";
503 :     }
504 :     # Close the JavaScript.
505 :     $retVal .= "</SCRIPT>\n";
506 :     }
507 :     # Return the result.
508 :     return $retVal;
509 :     }
510 :    
511 :     =head3 SetMessage
512 :    
513 :     C<< $shelp->SetMessage($msg); >>
514 :    
515 :     Store the specified text as the result message. The result message is displayed
516 :     if an invalid parameter value is specified.
517 :    
518 :     =over 4
519 :    
520 :     =item msg
521 :    
522 :     Text of the result message to be displayed.
523 :    
524 :     =back
525 :    
526 :     =cut
527 :    
528 :     sub SetMessage {
529 :     # Get the parameters.
530 :     my ($self, $msg) = @_;
531 :     # Store the message.
532 :     $self->{message} = $msg;
533 :     }
534 :    
535 :     =head3 Message
536 :    
537 :     C<< my $text = $shelp->Message(); >>
538 :    
539 :     Return the result message. The result message is displayed if an invalid parameter
540 :     value is specified.
541 :    
542 :     =cut
543 :    
544 :     sub Message {
545 :     # Get the parameters.
546 :     my ($self) = @_;
547 :     # Return the result.
548 :     return $self->{message};
549 :     }
550 :    
551 :     =head3 OpenSession
552 :    
553 : parrello 1.34 C<< $shelp->OpenSession($rhelp); >>
554 :    
555 :     Set up the session cache file and write out the column headers.
556 :     This method should not be called until all the columns have
557 :     been configured, including the extra columns.
558 :    
559 :     =over 4
560 :    
561 :     =item rhelp
562 :    
563 :     Result helper for formatting the output. This has the column
564 :     headers stored in it.
565 : parrello 1.1
566 : parrello 1.34 =back
567 : parrello 1.1
568 :     =cut
569 :    
570 :     sub OpenSession {
571 :     # Get the parameters.
572 : parrello 1.34 my ($self, $rhelp) = @_;
573 :     # Insure the result helper is valid.
574 :     if (! defined($rhelp)) {
575 :     Confess("No result type specified for $self->{class}.");
576 :     } elsif(! $rhelp->isa('ResultHelper')) {
577 :     Confess("Invalid result type specified for $self->{class}.");
578 :     } else {
579 :     # Get the column headers and write them out.
580 :     my $colHdrs = $rhelp->GetColumnHeaders();
581 :     Trace(scalar(@{$colHdrs}) . " column headers written to output.") if T(3);
582 :     $self->WriteColumnHeaders(@{$colHdrs});
583 :     }
584 : parrello 1.1 }
585 :    
586 :     =head3 GetCacheFileName
587 :    
588 :     C<< my $fileName = $shelp->GetCacheFileName(); >>
589 :    
590 :     Return the name to be used for this session's cache file.
591 :    
592 :     =cut
593 :    
594 :     sub GetCacheFileName {
595 :     # Get the parameters.
596 :     my ($self) = @_;
597 :     # Return the result.
598 :     return $self->GetTempFileName('cache');
599 :     }
600 :    
601 :     =head3 GetTempFileName
602 :    
603 :     C<< my $fileName = $shelp->GetTempFileName($type); >>
604 :    
605 :     Return the name to be used for a temporary file of the specified type. The
606 :     name is computed from the session name with the type as a suffix.
607 :    
608 :     =over 4
609 :    
610 :     =item type
611 :    
612 :     Type of temporary file to be generated.
613 :    
614 :     =item RETURN
615 :    
616 :     Returns a file name generated from the session name and the specified type.
617 :    
618 :     =back
619 :    
620 :     =cut
621 :    
622 :     sub GetTempFileName {
623 :     # Get the parameters.
624 :     my ($self, $type) = @_;
625 :     # Compute the file name. Note it gets stuffed in the FIG temporary
626 :     # directory.
627 : parrello 1.34 my $retVal = FIGRules::GetTempFileName(sessionID => $self->ID(), extension => $type);
628 : parrello 1.1 # Return the result.
629 :     return $retVal;
630 :     }
631 :    
632 :     =head3 WriteColumnHeaders
633 :    
634 :     C<< $shelp->WriteColumnHeaders(@colNames); >>
635 :    
636 :     Write out the column headers for the current search session. The column headers
637 :     are sent to the cache file, and then the cache is re-opened as a sort pipe and
638 :     the handle saved.
639 :    
640 :     =over 4
641 :    
642 :     =item colNames
643 :    
644 : parrello 1.34 A list of column names in the desired presentation order. For extra columns,
645 :     the column name is the hash supplied as the column definition.
646 : parrello 1.1
647 :     =back
648 :    
649 :     =cut
650 :    
651 :     sub WriteColumnHeaders {
652 :     # Get the parameters.
653 :     my ($self, @colNames) = @_;
654 :     # Get the cache file name and open it for output.
655 :     my $fileName = $self->GetCacheFileName();
656 :     my $handle1 = Open(undef, ">$fileName");
657 : parrello 1.34 # Freeze the column headers.
658 :     my @colHdrs = map { freeze($_) } @colNames;
659 : parrello 1.1 # Write the column headers and close the file.
660 : parrello 1.34 Tracer::PutLine($handle1, \@colHdrs);
661 : parrello 1.1 close $handle1;
662 :     # Now open the sort pipe and save the file handle. Note how we append the
663 :     # sorted data to the column header row already in place. The output will
664 :     # contain a sort key followed by the real columns. The sort key is
665 :     # hacked off before going to the output file.
666 :     $self->{fileHandle} = Open(undef, "| sort | cut --fields=2- >>$fileName");
667 :     }
668 :    
669 : parrello 1.34 =head3 ReadColumnHeaders
670 :    
671 :     C<< my @colHdrs = $shelp->ReadColumnHeaders($fh); >>
672 :    
673 :     Read the column headers from the specified file handle. The column headers are
674 :     frozen strings intermixed with frozen hash references. The strings represent
675 :     column names defined in the result helper. The hash references represent the
676 :     definitions of the extra columns.
677 :    
678 :     =over 4
679 :    
680 :     =item fh
681 :    
682 :     File handle from which the column headers are to be read.
683 :    
684 :     =item RETURN
685 :    
686 :     Returns a list of the column headers pulled from the specified file's first line.
687 :    
688 :     =back
689 :    
690 :     =cut
691 :    
692 :     sub ReadColumnHeaders {
693 :     # Get the parameters.
694 :     my ($self, $fh) = @_;
695 :     # Read and thaw the columns.
696 :     my @retVal = map { thaw($_) } Tracer::GetLine($fh);
697 :     # Return them to the caller.
698 :     return @retVal;
699 :     }
700 :    
701 : parrello 1.1 =head3 WriteColumnData
702 :    
703 :     C<< $shelp->WriteColumnData($key, @colValues); >>
704 :    
705 :     Write a row of column values to the current search session. It is assumed that
706 :     the session file is already open for output.
707 :    
708 :     =over 4
709 :    
710 :     =item key
711 :    
712 :     Sort key.
713 :    
714 :     =item colValues
715 :    
716 :     List of column values to write to the search result cache file for this session.
717 :    
718 :     =back
719 :    
720 :     =cut
721 :    
722 :     sub WriteColumnData {
723 :     # Get the parameters.
724 :     my ($self, $key, @colValues) = @_;
725 :     # Write them to the cache file.
726 :     Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);
727 : parrello 1.32 Trace("Column data is " . join("; ", $key, @colValues) . ".") if T(4);
728 : parrello 1.1 }
729 :    
730 :     =head3 CloseSession
731 :    
732 :     C<< $shelp->CloseSession(); >>
733 :    
734 :     Close the session file.
735 :    
736 :     =cut
737 :    
738 :     sub CloseSession {
739 :     # Get the parameters.
740 :     my ($self) = @_;
741 :     # Check for an open session file.
742 :     if (defined $self->{fileHandle}) {
743 :     # We found one, so close it.
744 : parrello 1.9 Trace("Closing session file.") if T(2);
745 : parrello 1.1 close $self->{fileHandle};
746 : parrello 1.28 # Tell the user.
747 :     my $cgi = $self->Q();
748 :     $self->PrintLine("Output formatting complete.<br />");
749 : parrello 1.1 }
750 :     }
751 :    
752 :     =head3 OrganismData
753 :    
754 : parrello 1.34 C<< my ($orgName, $group) = $shelp->Organism($genomeID); >>
755 : parrello 1.1
756 :     Return the name and status of the organism corresponding to the specified genome ID.
757 :     For performance reasons, this information is cached in a special hash table, so we
758 :     only compute it once per run.
759 :    
760 :     =over 4
761 :    
762 :     =item genomeID
763 :    
764 :     ID of the genome whose name is desired.
765 :    
766 :     =item RETURN
767 :    
768 : parrello 1.32 Returns a list of three items. The first item in the list is the organism name,
769 : parrello 1.1 and the second is the name of the NMPDR group, or an empty string if the
770 : parrello 1.32 organism is not in an NMPDR group. The third item is the organism's domain.
771 : parrello 1.1
772 :     =back
773 :    
774 :     =cut
775 :    
776 :     sub OrganismData {
777 :     # Get the parameters.
778 :     my ($self, $genomeID) = @_;
779 :     # Declare the return variables.
780 : parrello 1.32 my ($orgName, $group, $domain);
781 : parrello 1.1 # Check the cache.
782 :     my $cache = $self->{orgs};
783 :     if (exists $cache->{$genomeID}) {
784 : parrello 1.32 ($orgName, $group, $domain) = @{$cache->{$genomeID}};
785 : parrello 1.36 Trace("Cached organism $genomeID has group \"$group\".") if T(4);
786 : parrello 1.1 } else {
787 :     # Here we have to use the database.
788 :     my $sprout = $self->DB();
789 : parrello 1.36 my ($genus, $species, $strain, $newGroup, $taxonomy) = $sprout->GetEntityValues('Genome', $genomeID,
790 : parrello 1.32 ['Genome(genus)', 'Genome(species)',
791 :     'Genome(unique-characterization)',
792 :     'Genome(primary-group)',
793 :     'Genome(taxonomy)']);
794 : parrello 1.10 # Format and cache the name and display group.
795 : parrello 1.36 Trace("Caching organism $genomeID with group \"$newGroup\".") if T(4);
796 :     ($orgName, $group, $domain) = $self->SaveOrganismData($newGroup, $genomeID, $genus, $species,
797 : parrello 1.32 $strain, $taxonomy);
798 : parrello 1.36 Trace("Returning group $group.") if T(4);
799 : parrello 1.1 }
800 :     # Return the result.
801 : parrello 1.32 return ($orgName, $group, $domain);
802 : parrello 1.1 }
803 :    
804 :     =head3 Organism
805 :    
806 :     C<< my $orgName = $shelp->Organism($genomeID); >>
807 :    
808 :     Return the name of the relevant organism. The name is computed from the genus,
809 :     species, and unique characterization. A cache is used to improve performance.
810 :    
811 :     =over 4
812 :    
813 :     =item genomeID
814 :    
815 :     ID of the genome whose name is desired.
816 :    
817 :     =item RETURN
818 :    
819 :     Returns the display name of the specified organism.
820 :    
821 :     =back
822 :    
823 :     =cut
824 :    
825 :     sub Organism {
826 :     # Get the parameters.
827 :     my ($self, $genomeID) = @_;
828 :     # Get the organism data.
829 : parrello 1.32 my ($retVal) = $self->OrganismData($genomeID);
830 : parrello 1.1 # Return the result.
831 :     return $retVal;
832 :     }
833 :    
834 :     =head3 ComputeFASTA
835 :    
836 : parrello 1.32 C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence, $flankingWidth); >>
837 : parrello 1.1
838 : parrello 1.32 Parse a sequence input and convert it into a FASTA string of the desired type with
839 :     the desired flanking width.
840 : parrello 1.1
841 :     =over 4
842 :    
843 :     =item desiredType
844 :    
845 : parrello 1.34 C<dna> to return a DNA sequence, C<prot> to return a protein sequence, C<dnaPattern>
846 :     to return a DNA search pattern, C<protPattern> to return a protein search pattern.
847 : parrello 1.1
848 :     =item sequence
849 :    
850 :     Sequence to return. It may be a DNA or protein sequence in FASTA form or a feature ID.
851 :     If a feature ID is specified, the feature's DNA or translation will be returned. The
852 :     feature ID is recognized by the presence of a vertical bar in the input. Otherwise,
853 :     if the input does not begin with a greater-than sign (FASTA label line), a default label
854 :     line will be provided.
855 :    
856 : parrello 1.32 =item flankingWidth
857 :    
858 :     If the DNA FASTA of a feature is desired, the number of base pairs to either side of the
859 :     feature that should be included. Currently we can't do this for Proteins because the
860 :     protein translation of a feature doesn't always match the DNA and is taken directly
861 :     from the database.
862 :    
863 : parrello 1.1 =item RETURN
864 :    
865 :     Returns a string in FASTA format representing the content of the desired sequence with
866 :     an appropriate label. If the input is invalid, a message will be stored and we will
867 :     return C<undef>. Note that the output will include a trailing new-line.
868 :    
869 :     =back
870 :    
871 :     =cut
872 :    
873 :     sub ComputeFASTA {
874 :     # Get the parameters.
875 : parrello 1.32 my ($self, $desiredType, $sequence, $flankingWidth) = @_;
876 : parrello 1.1 # Declare the return variable. If an error occurs, it will remain undefined.
877 :     my $retVal;
878 : parrello 1.11 # This variable will be cleared if an error is detected.
879 :     my $okFlag = 1;
880 : parrello 1.1 # Create variables to hold the FASTA label and data.
881 :     my ($fastaLabel, $fastaData);
882 : parrello 1.18 Trace("FASTA desired type is $desiredType.") if T(4);
883 : parrello 1.29 # Check for a feature specification. The smoking gun for that is a vertical bar.
884 : parrello 1.1 if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
885 :     # Here we have a feature ID in $1. We'll need the Sprout object to process
886 :     # it.
887 :     my $fid = $1;
888 : parrello 1.11 Trace("Feature ID for fasta is $fid.") if T(3);
889 : parrello 1.1 my $sprout = $self->DB();
890 :     # Get the FIG ID. Note that we only use the first feature found. We are not
891 :     # supposed to have redundant aliases, though we may have an ID that doesn't
892 :     # exist.
893 :     my ($figID) = $sprout->FeaturesByAlias($fid);
894 :     if (! $figID) {
895 : parrello 1.17 $self->SetMessage("No gene found with the ID \"$fid\".");
896 : parrello 1.11 $okFlag = 0;
897 : parrello 1.1 } else {
898 : parrello 1.29 # Set the FASTA label. The ID is the first favored alias.
899 :     my $favored = $self->Q()->param('FavoredAlias') || 'fig';
900 :     my $favorLen = length $favored;
901 :     ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid);
902 :     if (! $fastaLabel) {
903 :     # In an emergency, fall back to the original ID.
904 :     $fastaLabel = $fid;
905 :     }
906 : parrello 1.1 # Now proceed according to the sequence type.
907 : parrello 1.33 if ($desiredType =~ /prot/) {
908 : parrello 1.1 # We want protein, so get the translation.
909 :     $fastaData = $sprout->FeatureTranslation($figID);
910 : parrello 1.11 Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
911 : parrello 1.34 } elsif ($desiredType =~ /dna/) {
912 : parrello 1.32 # We want DNA, so get the DNA sequence. This is a two-step process. First, we get the
913 :     # locations.
914 : parrello 1.1 my @locList = $sprout->FeatureLocation($figID);
915 : parrello 1.32 if ($flankingWidth > 0) {
916 :     # Here we need to add flanking data. Convert the locations to a list
917 :     # of location objects.
918 :     my @locObjects = map { BasicLocation->new($_) } @locList;
919 :     # Initialize the return variable. We will put the DNA in here segment by segment.
920 :     $fastaData = "";
921 :     # Now we widen each location by the flanking width and stash the results. This
922 :     # requires getting the contig length for each contig so we don't fall off the end.
923 :     for my $locObject (@locObjects) {
924 :     Trace("Current location is " . $locObject->String . ".") if T(4);
925 :     # Remember the current start and length.
926 :     my ($start, $len) = ($locObject->Left, $locObject->Length);
927 :     # Get the contig length.
928 :     my $contigLen = $sprout->ContigLength($locObject->Contig);
929 :     # Widen the location and get its DNA.
930 :     $locObject->Widen($flankingWidth, $contigLen);
931 :     my $fastaSegment = $sprout->DNASeq([$locObject->String()]);
932 :     # Now we need to do some case changing. The main DNA is upper case and
933 :     # the flanking DNA is lower case.
934 :     my $leftFlank = $start - $locObject->Left;
935 :     my $rightFlank = $leftFlank + $len;
936 :     Trace("Wide location is " . $locObject->String . ". Flanks are $leftFlank and $rightFlank. Contig len is $contigLen.") if T(4);
937 :     my $fancyFastaSegment = lc(substr($fastaSegment, 0, $leftFlank)) .
938 :     uc(substr($fastaSegment, $leftFlank, $rightFlank - $leftFlank)) .
939 :     lc(substr($fastaSegment, $rightFlank));
940 :     $fastaData .= $fancyFastaSegment;
941 :     }
942 :     } else {
943 :     # Here we have just the raw sequence.
944 :     $fastaData = $sprout->DNASeq(\@locList);
945 :     }
946 :     Trace((length $fastaData) . " characters returned for DNA of $fastaLabel.") if T(3);
947 : parrello 1.1 }
948 :     }
949 :     } else {
950 : parrello 1.11 Trace("Analyzing FASTA sequence.") if T(4);
951 : parrello 1.1 # Here we are expecting a FASTA. We need to see if there's a label.
952 : parrello 1.11 if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) {
953 :     Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4);
954 : parrello 1.1 # Here we have a label, so we split it from the data.
955 :     $fastaLabel = $1;
956 :     $fastaData = $2;
957 :     } else {
958 : parrello 1.11 Trace("No label found in match to sequence:\n$sequence") if T(4);
959 : parrello 1.1 # Here we have no label, so we create one and use the entire sequence
960 :     # as data.
961 : parrello 1.34 $fastaLabel = "$desiredType sequence specified by user";
962 : parrello 1.1 $fastaData = $sequence;
963 :     }
964 : parrello 1.34 # If we are not doing a pattern search, we need to clean the junk out of the sequence.
965 :     if ($desiredType !~ /pattern/i) {
966 :     $fastaData =~ s/\n//g;
967 :     $fastaData =~ s/\s+//g;
968 :     }
969 : parrello 1.18 # Finally, verify that it's DNA if we're doing DNA stuff.
970 : parrello 1.34 if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn-]/i) {
971 : parrello 1.24 $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?");
972 : parrello 1.11 $okFlag = 0;
973 : parrello 1.1 }
974 :     }
975 : parrello 1.11 Trace("FASTA data sequence: $fastaData") if T(4);
976 :     # Only proceed if no error was detected.
977 :     if ($okFlag) {
978 : parrello 1.33 if ($desiredType =~ /pattern/i) {
979 : parrello 1.34 # For a scan, there is no label and no breakup.
980 : parrello 1.33 $retVal = $fastaData;
981 :     } else {
982 :     # We need to format the sequence into 60-byte chunks. We use the infamous
983 :     # grep-split trick. The split, because of the presence of the parentheses,
984 :     # includes the matched delimiters in the output list. The grep strips out
985 :     # the empty list items that appear between the so-called delimiters, since
986 :     # the delimiters are what we want.
987 :     my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
988 :     $retVal = join("\n", ">$fastaLabel", @chunks, "");
989 :     }
990 : parrello 1.1 }
991 :     # Return the result.
992 :     return $retVal;
993 :     }
994 :    
995 : parrello 1.16 =head3 SubsystemTree
996 :    
997 :     C<< my $tree = SearchHelper::SubsystemTree($sprout, %options); >>
998 :    
999 :     This method creates a subsystem selection tree suitable for passing to
1000 :     L</SelectionTree>. Each leaf node in the tree will have a link to the
1001 :     subsystem display page. In addition, each node can have a radio button. The
1002 :     radio button alue is either C<classification=>I<string>, where I<string> is
1003 :     a classification string, or C<id=>I<string>, where I<string> is a subsystem ID.
1004 :     Thus, it can either be used to filter by a group of related subsystems or a
1005 :     single subsystem.
1006 :    
1007 :     =over 4
1008 :    
1009 :     =item sprout
1010 :    
1011 :     Sprout database object used to get the list of subsystems.
1012 :    
1013 :     =item options
1014 :    
1015 :     Hash containing options for building the tree.
1016 :    
1017 :     =item RETURN
1018 :    
1019 :     Returns a reference to a tree list suitable for passing to L</SelectionTree>.
1020 :    
1021 :     =back
1022 :    
1023 :     The supported options are as follows.
1024 :    
1025 :     =over 4
1026 :    
1027 :     =item radio
1028 :    
1029 :     TRUE if the tree should be configured for radio buttons. The default is FALSE.
1030 :    
1031 :     =item links
1032 :    
1033 :     TRUE if the tree should be configured for links. The default is TRUE.
1034 :    
1035 :     =back
1036 :    
1037 :     =cut
1038 :    
1039 :     sub SubsystemTree {
1040 :     # Get the parameters.
1041 :     my ($sprout, %options) = @_;
1042 :     # Process the options.
1043 :     my $optionThing = Tracer::GetOptions({ radio => 0, links => 1 }, \%options);
1044 :     # Read in the subsystems.
1045 :     my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1046 :     ['Subsystem(classification)', 'Subsystem(id)']);
1047 : parrello 1.26 # Put any unclassified subsystems at the end. They will always be at the beginning, so if one
1048 :     # is at the end, ALL subsystems are unclassified and we don't bother.
1049 :     if ($#subs >= 0 && $subs[$#subs]->[0] ne '') {
1050 :     while ($subs[0]->[0] eq '') {
1051 :     my $classLess = shift @subs;
1052 :     push @subs, $classLess;
1053 :     }
1054 :     }
1055 : parrello 1.16 # Declare the return variable.
1056 :     my @retVal = ();
1057 :     # Each element in @subs represents a leaf node, so as we loop through it we will be
1058 :     # producing one leaf node at a time. The leaf node is represented as a 2-tuple. The
1059 :     # first element is a semi-colon-delimited list of the classifications for the
1060 :     # subsystem. There will be a stack of currently-active classifications, which we will
1061 :     # compare to the incoming classifications from the end backward. A new classification
1062 :     # requires starting a new branch. A different classification requires closing an old
1063 :     # branch and starting a new one. Each classification in the stack will also contain
1064 :     # that classification's current branch. We'll add a fake classification at the
1065 :     # beginning that we can use to represent the tree as a whole.
1066 :     my $rootName = '<root>';
1067 :     # Create the classification stack. Note the stack is a pair of parallel lists,
1068 :     # one containing names and the other containing content.
1069 :     my @stackNames = ($rootName);
1070 :     my @stackContents = (\@retVal);
1071 :     # Add a null entry at the end of the subsystem list to force an unrolling.
1072 : parrello 1.27 push @subs, ['', undef];
1073 : parrello 1.16 # Loop through the subsystems.
1074 :     for my $sub (@subs) {
1075 :     # Pull out the classification list and the subsystem ID.
1076 :     my ($classString, $id) = @{$sub};
1077 :     Trace("Processing class \"$classString\" and subsystem $id.") if T(4);
1078 :     # Convert the classification string to a list with the root classification in
1079 :     # the front.
1080 :     my @classList = ($rootName, split($FIG_Config::splitter, $classString));
1081 :     # Find the leftmost point at which the class list differs from the stack.
1082 :     my $matchPoint = 0;
1083 :     while ($matchPoint <= $#stackNames && $matchPoint <= $#classList &&
1084 :     $stackNames[$matchPoint] eq $classList[$matchPoint]) {
1085 :     $matchPoint++;
1086 :     }
1087 :     Trace("Match point is $matchPoint. Stack length is " . scalar(@stackNames) .
1088 :     ". Class List length is " . scalar(@classList) . ".") if T(4);
1089 :     # Unroll the stack to the matchpoint.
1090 :     while ($#stackNames >= $matchPoint) {
1091 :     my $popped = pop @stackNames;
1092 :     pop @stackContents;
1093 :     Trace("\"$popped\" popped from stack.") if T(4);
1094 :     }
1095 :     # Start branches for any new classifications.
1096 :     while ($#stackNames < $#classList) {
1097 :     # The branch for a new classification contains its radio button
1098 :     # data and then a list of children. So, at this point, if radio buttons
1099 :     # are desired, we put them into the content.
1100 :     my $newLevel = scalar(@stackNames);
1101 :     my @newClassContent = ();
1102 :     if ($optionThing->{radio}) {
1103 :     my $newClassString = join($FIG_Config::splitter, @classList[1..$newLevel]);
1104 :     push @newClassContent, { value => "classification=$newClassString%" };
1105 :     }
1106 :     # The new classification node is appended to its parent's content
1107 :     # and then pushed onto the stack. First, we need the node name.
1108 :     my $nodeName = $classList[$newLevel];
1109 :     # Add the classification to its parent. This makes it part of the
1110 :     # tree we'll be returning to the user.
1111 :     push @{$stackContents[$#stackNames]}, $nodeName, \@newClassContent;
1112 :     # Push the classification onto the stack.
1113 :     push @stackContents, \@newClassContent;
1114 :     push @stackNames, $nodeName;
1115 :     Trace("\"$nodeName\" pushed onto stack.") if T(4);
1116 :     }
1117 :     # Now the stack contains all our parent branches. We add the subsystem to
1118 :     # the branch at the top of the stack, but only if it's NOT the dummy node.
1119 :     if (defined $id) {
1120 :     # Compute the node name from the ID.
1121 :     my $nodeName = $id;
1122 :     $nodeName =~ s/_/ /g;
1123 :     # Create the node's leaf hash. This depends on the value of the radio
1124 :     # and link options.
1125 :     my $nodeContent = {};
1126 :     if ($optionThing->{links}) {
1127 :     # Compute the link value.
1128 :     my $linkable = uri_escape($id);
1129 : parrello 1.28 $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;show_clusters=1;SPROUT=1";
1130 : parrello 1.16 }
1131 :     if ($optionThing->{radio}) {
1132 :     # Compute the radio value.
1133 :     $nodeContent->{value} = "id=$id";
1134 :     }
1135 :     # Push the node into its parent branch.
1136 :     Trace("\"$nodeName\" added to node list.") if T(4);
1137 :     push @{$stackContents[$#stackNames]}, $nodeName, $nodeContent;
1138 :     }
1139 :     }
1140 :     # Return the result.
1141 :     return \@retVal;
1142 :     }
1143 :    
1144 :    
1145 : parrello 1.1 =head3 NmpdrGenomeMenu
1146 :    
1147 : parrello 1.3 C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>
1148 : parrello 1.1
1149 :     This method creates a hierarchical HTML menu for NMPDR genomes organized by category. The
1150 :     category indicates the low-level NMPDR group. Organizing the genomes in this way makes it
1151 :     easier to select all genomes from a particular category.
1152 :    
1153 :     =over 4
1154 :    
1155 :     =item menuName
1156 :    
1157 :     Name to give to the menu.
1158 :    
1159 : parrello 1.3 =item multiple
1160 : parrello 1.1
1161 : parrello 1.3 TRUE if the user is allowed to select multiple genomes, else FALSE.
1162 : parrello 1.1
1163 :     =item selected
1164 :    
1165 :     Reference to a list containing the IDs of the genomes to be pre-selected. If the menu
1166 :     is not intended to allow multiple selections, the list should be a singleton. If the
1167 :     list is empty, nothing will be pre-selected.
1168 :    
1169 : parrello 1.3 =item rows (optional)
1170 :    
1171 :     Number of rows to display. If omitted, the default is 1 for a single-select list
1172 :     and 10 for a multi-select list.
1173 :    
1174 : parrello 1.8 =item crossMenu (optional)
1175 :    
1176 :     If specified, is presumed to be the name of another genome menu whose contents
1177 :     are to be mutually exclusive with the contents of this menu. As a result, instead
1178 :     of the standard onChange event, the onChange event will deselect any entries in
1179 :     the other menu.
1180 :    
1181 : parrello 1.1 =item RETURN
1182 :    
1183 :     Returns the HTML text to generate a C<SELECT> menu inside a form.
1184 :    
1185 :     =back
1186 :    
1187 :     =cut
1188 :    
1189 :     sub NmpdrGenomeMenu {
1190 :     # Get the parameters.
1191 : parrello 1.8 my ($self, $menuName, $multiple, $selected, $rows, $cross) = @_;
1192 : parrello 1.1 # Get the Sprout and CGI objects.
1193 :     my $sprout = $self->DB();
1194 :     my $cgi = $self->Q();
1195 : parrello 1.3 # Compute the row count.
1196 :     if (! defined $rows) {
1197 :     $rows = ($multiple ? 10 : 1);
1198 :     }
1199 :     # Create the multiple tag.
1200 :     my $multipleTag = ($multiple ? " multiple" : "");
1201 : parrello 1.1 # Get the form name.
1202 :     my $formName = $self->FormName();
1203 : parrello 1.3 # Check to see if we already have a genome list in memory.
1204 : parrello 1.32 my $groupHash;
1205 :     my @groups;
1206 :     my $nmpdrGroupCount;
1207 : parrello 1.3 my $genomes = $self->{genomeList};
1208 :     if (defined $genomes) {
1209 :     # We have a list ready to use.
1210 :     $groupHash = $genomes;
1211 : parrello 1.32 @groups = @{$self->{groupList}};
1212 :     $nmpdrGroupCount = $self->{groupCount};
1213 : parrello 1.3 } else {
1214 :     # Get a list of all the genomes in group order. In fact, we only need them ordered
1215 :     # by name (genus,species,strain), but putting primary-group in front enables us to
1216 :     # take advantage of an existing index.
1217 :     my @genomeList = $sprout->GetAll(['Genome'],
1218 :     "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",
1219 :     [], ['Genome(primary-group)', 'Genome(id)',
1220 :     'Genome(genus)', 'Genome(species)',
1221 : parrello 1.32 'Genome(unique-characterization)',
1222 :     'Genome(taxonomy)']);
1223 : parrello 1.3 # Create a hash to organize the genomes by group. Each group will contain a list of
1224 :     # 2-tuples, the first element being the genome ID and the second being the genome
1225 :     # name.
1226 :     my %gHash = ();
1227 :     for my $genome (@genomeList) {
1228 :     # Get the genome data.
1229 : parrello 1.32 my ($group, $genomeID, $genus, $species, $strain, $taxonomy) = @{$genome};
1230 : parrello 1.10 # Compute and cache its name and display group.
1231 : parrello 1.32 my ($name, $displayGroup, $domain) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1232 :     $strain, $taxonomy);
1233 : parrello 1.10 # Push the genome into the group's list. Note that we use the real group
1234 :     # name here, not the display group name.
1235 : parrello 1.32 push @{$gHash{$group}}, [$genomeID, $name, $domain];
1236 :     }
1237 :     # We are almost ready to unroll the menu out of the group hash. The final step is to separate
1238 :     # the supporting genomes by domain. First, we sort the NMPDR groups.
1239 :     @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %gHash;
1240 :     # Remember the number of NMPDR groups.
1241 :     $nmpdrGroupCount = scalar @groups;
1242 :     # Loop through the supporting genomes, classifying them by domain. We'll also keep a list
1243 :     # of the domains found.
1244 :     my @otherGenomes = @{$gHash{$FIG_Config::otherGroup}};
1245 :     my @domains = ();
1246 :     for my $genomeData (@otherGenomes) {
1247 :     my ($genomeID, $name, $domain) = @{$genomeData};
1248 :     if (exists $gHash{$domain}) {
1249 :     push @{$gHash{$domain}}, $genomeData;
1250 :     } else {
1251 :     $gHash{$domain} = [$genomeData];
1252 :     push @domains, $domain;
1253 :     }
1254 : parrello 1.1 }
1255 : parrello 1.32 # Add the domain groups at the end of the main group list. The main group list will now
1256 :     # contain all the categories we need to display the genomes.
1257 :     push @groups, sort @domains;
1258 :     # Delete the supporting group.
1259 :     delete $gHash{$FIG_Config::otherGroup};
1260 : parrello 1.3 # Save the genome list for future use.
1261 :     $self->{genomeList} = \%gHash;
1262 : parrello 1.32 $self->{groupList} = \@groups;
1263 :     $self->{groupCount} = $nmpdrGroupCount;
1264 : parrello 1.3 $groupHash = \%gHash;
1265 : parrello 1.1 }
1266 : parrello 1.3 # Next, create a hash that specifies the pre-selected entries. Note that we need to deal
1267 :     # with the possibility of undefined values in the incoming list.
1268 :     my %selectedHash = ();
1269 :     if (defined $selected) {
1270 :     %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};
1271 :     }
1272 : parrello 1.13 # Now it gets complicated. We need a way to mark all the NMPDR genomes. We take advantage
1273 :     # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes
1274 :     # and use that to make the selections.
1275 :     my $nmpdrCount = 0;
1276 : parrello 1.1 # Create the type counters.
1277 :     my $groupCount = 1;
1278 :     # Compute the ID for the status display.
1279 :     my $divID = "${formName}_${menuName}_status";
1280 :     # Compute the JavaScript call for updating the status.
1281 :     my $showSelect = "showSelected($menuName, '$divID', 1000);";
1282 :     # If multiple selection is supported, create an onChange event.
1283 :     my $onChange = "";
1284 : parrello 1.8 if ($cross) {
1285 : parrello 1.13 # Here we have a paired menu. Selecting something in our menu unselects it in the
1286 :     # other and redisplays the status of both.
1287 : parrello 1.8 $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";
1288 :     } elsif ($multiple) {
1289 : parrello 1.13 # This is an unpaired menu, so all we do is redisplay our status.
1290 : parrello 1.1 $onChange = " onChange=\"$showSelect\"";
1291 :     }
1292 :     # Create the SELECT tag and stuff it into the output array.
1293 : parrello 1.13 my @lines = ("<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">");
1294 : parrello 1.1 # Loop through the groups.
1295 :     for my $group (@groups) {
1296 :     # Create the option group tag.
1297 :     my $tag = "<OPTGROUP label=\"$group\">";
1298 :     push @lines, " $tag";
1299 :     # Get the genomes in the group.
1300 : parrello 1.3 for my $genome (@{$groupHash->{$group}}) {
1301 : parrello 1.13 # Count this organism if it's NMPDR.
1302 : parrello 1.32 if ($nmpdrGroupCount > 0) {
1303 : parrello 1.13 $nmpdrCount++;
1304 :     }
1305 : parrello 1.32 # Get the organism ID, name, and domain.
1306 :     my ($genomeID, $name, $domain) = @{$genome};
1307 : parrello 1.1 # See if it's selected.
1308 :     my $select = ($selectedHash{$genomeID} ? " selected" : "");
1309 :     # Generate the option tag.
1310 : parrello 1.32 my $optionTag = "<OPTION class=\"$domain\" value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";
1311 : parrello 1.1 push @lines, " $optionTag";
1312 :     }
1313 :     # Close the option group.
1314 :     push @lines, " </OPTGROUP>";
1315 : parrello 1.32 # Record this group in the nmpdrGroup count. When that gets to 0, we've finished the NMPDR
1316 :     # groups.
1317 :     $nmpdrGroupCount--;
1318 : parrello 1.1 }
1319 :     # Close the SELECT tag.
1320 :     push @lines, "</SELECT>";
1321 :     # Check for multiple selection.
1322 : parrello 1.3 if ($multiple) {
1323 : parrello 1.15 # Multi-select is on, so we need to add some selection helpers. First is
1324 :     # the search box. This allows the user to type text and have all genomes containing
1325 :     # the text selected automatically.
1326 :     my $searchThingName = "${menuName}_SearchThing";
1327 : parrello 1.18 push @lines, "<br />" .
1328 : parrello 1.34 "<INPUT type=\"button\" name=\"MacroSearch\" class=\"button\" value=\"Select genomes containing\" onClick=\"selectViaSearch($menuName, $searchThingName); $showSelect\" />&nbsp;" .
1329 : parrello 1.37 "<INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />" . Hint("Genome Control",
1330 :     "Enter a genome number, then click the button to the left " .
1331 : parrello 1.34 "in order to select the genome with that number. " .
1332 :     "Enter a genus, species, or strain and click the " .
1333 :     "button to select all genomes with that genus, species, " .
1334 :     "or strain name.");
1335 : parrello 1.15 # Next are the buttons to set and clear selections.
1336 : parrello 1.1 push @lines, "<br />";
1337 : parrello 1.15 push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\" value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";
1338 : parrello 1.1 push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";
1339 : parrello 1.13 push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\" value=\"Select NMPDR\" onClick=\"selectSome($menuName, $nmpdrCount, true); $showSelect\" />";
1340 : parrello 1.37 # push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, $nmpdrCount, false); $showSelect\" />";
1341 : parrello 1.1 # Add the status display, too.
1342 :     push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";
1343 :     # Queue to update the status display when the form loads. We need to modify the show statement
1344 :     # slightly because the queued statements are executed outside the form. This may seem like a lot of
1345 :     # trouble, but we want all of the show statement calls to be generated from a single line of code,
1346 :     # in case we decide to twiddle the parameters.
1347 :     $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;
1348 :     $self->QueueFormScript($showSelect);
1349 : parrello 1.3 # Finally, add this parameter to the list of genome parameters. This enables us to
1350 :     # easily find all the parameters used to select one or more genomes.
1351 :     push @{$self->{genomeParms}}, $menuName;
1352 : parrello 1.1 }
1353 :     # Assemble all the lines into a string.
1354 :     my $retVal = join("\n", @lines, "");
1355 :     # Return the result.
1356 :     return $retVal;
1357 :     }
1358 :    
1359 : parrello 1.3 =head3 PropertyMenu
1360 :    
1361 :     C<< my $htmlText = $shelp->PropertyMenu($menuName, $selected, $force); >>
1362 :    
1363 :     Generate a property name dropdown menu.
1364 :    
1365 :     =over 4
1366 :    
1367 :     =item menuName
1368 :    
1369 :     Name to give to the menu.
1370 :    
1371 :     =item selected
1372 :    
1373 :     Value of the property name to pre-select.
1374 :    
1375 :     =item force (optional)
1376 :    
1377 :     If TRUE, then the user will be forced to choose a property name. If FALSE,
1378 :     then an additional menu choice will be provided to select nothing.
1379 :    
1380 :     =item RETURN
1381 :    
1382 :     Returns a dropdown menu box that allows the user to select a property name. An additional
1383 :     selection entry will be provided for selecting no property name
1384 :    
1385 :     =back
1386 :    
1387 :     =cut
1388 :    
1389 :     sub PropertyMenu {
1390 :     # Get the parameters.
1391 :     my ($self, $menuName, $selected, $force) = @_;
1392 :     # Get the CGI and Sprout objects.
1393 :     my $sprout = $self->DB();
1394 :     my $cgi = $self->Q();
1395 :     # Create the property name list.
1396 :     my @propNames = ();
1397 :     if (! $force) {
1398 :     push @propNames, "";
1399 :     }
1400 :     # Get all the property names, putting them after the null choice if one exists.
1401 :     push @propNames, $sprout->GetChoices('Property', 'property-name');
1402 :     # Create a menu from them.
1403 :     my $retVal = $cgi->popup_menu(-name=> $menuName, -values => \@propNames,
1404 :     -default => $selected);
1405 :     # Return the result.
1406 :     return $retVal;
1407 :     }
1408 :    
1409 : parrello 1.1 =head3 MakeTable
1410 :    
1411 :     C<< my $htmlText = $shelp->MakeTable(\@rows); >>
1412 :    
1413 :     Create a table from a group of table rows. The table rows must be fully pre-formatted: in
1414 :     other words, each must have the TR and TD tags included.
1415 :    
1416 :     The purpose of this method is to provide a uniform look for search form tables. It is
1417 :     almost impossible to control a table using styles, so rather than have a table style,
1418 :     we create the TABLE tag in this method. Note also that the first TD or TH in each row will
1419 :     be updated with an explicit width so the forms look pretty when they are all on one
1420 :     page.
1421 :    
1422 :     =over 4
1423 :    
1424 :     =item rows
1425 :    
1426 :     Reference to a list of table rows. Each table row must be in HTML form with all
1427 : parrello 1.29 the TR and TD tags set up. The first TD or TH tag in the first non-colspanned row
1428 :     will be modified to set the width. Everything else will be left as is.
1429 : parrello 1.1
1430 :     =item RETURN
1431 :    
1432 :     Returns the full HTML for a table in the approved NMPDR Search Form style.
1433 :    
1434 :     =back
1435 :    
1436 :     =cut
1437 :    
1438 :     sub MakeTable {
1439 :     # Get the parameters.
1440 :     my ($self, $rows) = @_;
1441 :     # Get the CGI object.
1442 :     my $cgi = $self->Q();
1443 : parrello 1.29 # The first column of the first row must have its width fixed.
1444 :     # This flag will be set to FALSE when that happens.
1445 :     my $needWidth = 1;
1446 : parrello 1.1 # modifier becase we only want to change the first tag. Also, if a width
1447 :     # is already specified on the first column bad things will happen.
1448 :     for my $row (@{$rows}) {
1449 : parrello 1.29 # See if this row needs a width.
1450 :     if ($needWidth && $row =~ /<(td|th) ([^>]+)>/i) {
1451 :     # Here we have a first cell and its tag parameters are in $2.
1452 :     my $elements = $2;
1453 :     if ($elements !~ /colspan/i) {
1454 :     Trace("No colspan tag found in element \'$elements\'.") if T(3);
1455 :     # Here there's no colspan, so we plug in the width. We
1456 :     # eschew the "g" modifier on the substitution because we
1457 :     # only want to update the first cell.
1458 :     $row =~ s/(<(td|th))/$1 width="150"/i;
1459 :     # Denote we don't need this any more.
1460 :     $needWidth = 0;
1461 :     }
1462 :     }
1463 : parrello 1.1 }
1464 :     # Create the table.
1465 :     my $retVal = $cgi->table({border => 2, cellspacing => 2,
1466 :     width => 700, class => 'search'},
1467 :     @{$rows});
1468 :     # Return the result.
1469 :     return $retVal;
1470 :     }
1471 :    
1472 :     =head3 SubmitRow
1473 :    
1474 : parrello 1.18 C<< my $htmlText = $shelp->SubmitRow($caption); >>
1475 : parrello 1.1
1476 :     Returns the HTML text for the row containing the page size control
1477 :     and the submit button. All searches should have this row somewhere
1478 :     near the top of the form.
1479 :    
1480 : parrello 1.18 =over 4
1481 :    
1482 :     =item caption (optional)
1483 :    
1484 :     Caption to be put on the search button. The default is C<Go>.
1485 :    
1486 :     =item RETURN
1487 :    
1488 :     Returns a table row containing the controls for submitting the search
1489 :     and tuning the results.
1490 :    
1491 :     =back
1492 :    
1493 : parrello 1.1 =cut
1494 :    
1495 :     sub SubmitRow {
1496 :     # Get the parameters.
1497 : parrello 1.18 my ($self, $caption) = @_;
1498 : parrello 1.1 my $cgi = $self->Q();
1499 : parrello 1.18 # Compute the button caption.
1500 :     my $realCaption = (defined $caption ? $caption : 'Go');
1501 : parrello 1.3 # Get the current page size.
1502 :     my $pageSize = $cgi->param('PageSize');
1503 : parrello 1.34 # Get the current feature ID type.
1504 :     my $aliasType = $self->GetPreferredAliasType();
1505 :     # Create the rows.
1506 : parrello 1.37 my $retVal = $cgi->Tr($cgi->td("Identifier Type "),
1507 :     $cgi->td({ colspan => 2 },
1508 :     $cgi->popup_menu(-name => 'AliasType',
1509 :     -values => ['FIG', AliasAnalysis::AliasTypes() ],
1510 :     -default => $aliasType) .
1511 :     Hint("Identifier type", "Specify how you want gene names to be displayed."))) .
1512 : parrello 1.34 "\n" .
1513 :     $cgi->Tr($cgi->td("Results/Page"),
1514 : parrello 1.1 $cgi->td($cgi->popup_menu(-name => 'PageSize',
1515 : parrello 1.7 -values => [10, 25, 50, 100, 1000],
1516 : parrello 1.25 -default => $pageSize)),
1517 : parrello 1.1 $cgi->td($cgi->submit(-class => 'goButton',
1518 :     -name => 'Search',
1519 : parrello 1.18 -value => $realCaption)));
1520 : parrello 1.1 # Return the result.
1521 :     return $retVal;
1522 :     }
1523 : parrello 1.2
1524 : parrello 1.3 =head3 GetGenomes
1525 :    
1526 :     C<< my @genomeList = $shelp->GetGenomes($parmName); >>
1527 :    
1528 :     Return the list of genomes specified by the specified CGI query parameter.
1529 :     If the request method is POST, then the list of genome IDs is returned
1530 :     without preamble. If the request method is GET and the parameter is not
1531 :     specified, then it is treated as a request for all genomes. This makes it
1532 :     easier for web pages to link to a search that wants to specify all genomes.
1533 :    
1534 :     =over 4
1535 :    
1536 :     =item parmName
1537 :    
1538 :     Name of the parameter containing the list of genomes. This will be the
1539 :     first parameter passed to the L</NmpdrGenomeMenu> call that created the
1540 :     genome selection control on the form.
1541 :    
1542 :     =item RETURN
1543 :    
1544 :     Returns a list of the genomes to process.
1545 :    
1546 :     =back
1547 :    
1548 :     =cut
1549 :    
1550 :     sub GetGenomes {
1551 :     # Get the parameters.
1552 :     my ($self, $parmName) = @_;
1553 :     # Get the CGI query object.
1554 :     my $cgi = $self->Q();
1555 :     # Get the list of genome IDs in the request header.
1556 :     my @retVal = $cgi->param($parmName);
1557 :     Trace("Genome list for $parmName is (" . join(", ", @retVal) . ") with method " . $cgi->request_method() . ".") if T(3);
1558 :     # Check for the special GET case.
1559 :     if ($cgi->request_method() eq "GET" && ! @retVal) {
1560 :     # Here the caller wants all the genomes.
1561 :     my $sprout = $self->DB();
1562 :     @retVal = $sprout->Genomes();
1563 :     }
1564 :     # Return the result.
1565 :     return @retVal;
1566 :     }
1567 :    
1568 :     =head3 GetHelpText
1569 :    
1570 :     C<< my $htmlText = $shelp->GetHelpText(); >>
1571 :    
1572 :     Get the help text for this search. The help text is stored in files on the template
1573 :     server. The help text for a specific search is taken from a file named
1574 :     C<SearchHelp_>I<class>C<.inc> in the template directory C<$FIG_Config::template_url>.
1575 :     There are also three standard help files: C<SearchHelp1_Filtering.inc> describes the
1576 : parrello 1.35 feature filtering performed by the B<RHFeatures> object, C<SearchHelp1_GenomeControl.inc>
1577 : parrello 1.3 describes how to use a multiple-selection genome control, and C<SearchHelp1_Standard.inc>
1578 :     describes the standard controls for a search, such as page size, URL display, and
1579 :     external alias display.
1580 :    
1581 :     =cut
1582 :    
1583 :     sub GetHelpText {
1584 :     # Get the parameters.
1585 :     my ($self) = @_;
1586 :     # Create a list to hold the pieces of the help.
1587 :     my @helps = ();
1588 :     # Get the template directory URL.
1589 :     my $urlBase = $FIG_Config::template_url;
1590 :     # Start with the specific help.
1591 :     my $class = $self->{class};
1592 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp_$class.inc");
1593 :     # Add the genome control help if needed.
1594 :     if (scalar @{$self->{genomeParms}}) {
1595 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_GenomeControl.inc");
1596 :     }
1597 :     # Next the filter help.
1598 :     if ($self->{filtered}) {
1599 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Filtering.inc");
1600 :     }
1601 :     # Finally, the standard help.
1602 :     push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Standard.inc");
1603 :     # Assemble the pieces.
1604 :     my $retVal = join("\n<p>&nbsp;</p>\n", @helps);
1605 :     # Return the result.
1606 :     return $retVal;
1607 :     }
1608 :    
1609 :     =head3 ComputeSearchURL
1610 :    
1611 : parrello 1.19 C<< my $url = $shelp->ComputeSearchURL(%overrides); >>
1612 : parrello 1.3
1613 :     Compute the GET-style URL for the current search. In order for this to work, there
1614 :     must be a copy of the search form on the current page. This will always be the
1615 :     case if the search is coming from C<SearchSkeleton.cgi>.
1616 :    
1617 :     A little expense is involved in order to make the URL as smart as possible. The
1618 :     main complication is that if the user specified all genomes, we'll want to
1619 :     remove the parameter entirely from a get-style URL.
1620 :    
1621 : parrello 1.19 =over 4
1622 :    
1623 :     =item overrides
1624 :    
1625 :     Hash containing override values for the parameters, where the parameter name is
1626 :     the key and the parameter value is the override value. If the override value is
1627 :     C<undef>, the parameter will be deleted from the result.
1628 :    
1629 :     =item RETURN
1630 :    
1631 :     Returns a GET-style URL for invoking the search with the specified overrides.
1632 :    
1633 :     =back
1634 :    
1635 : parrello 1.3 =cut
1636 :    
1637 :     sub ComputeSearchURL {
1638 :     # Get the parameters.
1639 : parrello 1.19 my ($self, %overrides) = @_;
1640 : parrello 1.3 # Get the database and CGI query object.
1641 :     my $cgi = $self->Q();
1642 :     my $sprout = $self->DB();
1643 :     # Start with the full URL.
1644 :     my $retVal = $cgi->url(-full => 1);
1645 :     # Get all the query parameters in a hash.
1646 :     my %parms = $cgi->Vars();
1647 :     # Now we need to do some fixing. Each multi-valued parameter is encoded as a string with null
1648 :     # characters separating the individual values. We have to convert those to lists. In addition,
1649 :     # the multiple-selection genome parameters and the feature type parameter must be checked to
1650 :     # determine whether or not they can be removed from the URL. First, we get a list of the
1651 :     # genome parameters and a list of all genomes. Note that we only need the list if a
1652 :     # multiple-selection genome parameter has been found on the form.
1653 :     my %genomeParms = map { $_ => 1 } @{$self->{genomeParms}};
1654 :     my @genomeList;
1655 :     if (keys %genomeParms) {
1656 :     @genomeList = $sprout->Genomes();
1657 :     }
1658 :     # Create a list to hold the URL parameters we find.
1659 :     my @urlList = ();
1660 :     # Now loop through the parameters in the hash, putting them into the output URL.
1661 :     for my $parmKey (keys %parms) {
1662 :     # Get a list of the parameter values. If there's only one, we'll end up with
1663 :     # a singleton list, but that's okay.
1664 :     my @values = split (/\0/, $parms{$parmKey});
1665 :     # Check for special cases.
1666 : parrello 1.26 if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) {
1667 : parrello 1.3 # These are bookkeeping parameters we don't need to start a search.
1668 :     @values = ();
1669 :     } elsif ($parmKey =~ /_SearchThing$/) {
1670 :     # Here the value coming in is from a genome control's search thing. It does
1671 :     # not affect the results of the search, so we clear it.
1672 :     @values = ();
1673 :     } elsif ($genomeParms{$parmKey}) {
1674 :     # Here we need to see if the user wants all the genomes. If he does,
1675 :     # we erase all the values just like with features.
1676 :     my $allFlag = $sprout->IsAllGenomes(\@values, \@genomeList);
1677 :     if ($allFlag) {
1678 :     @values = ();
1679 :     }
1680 : parrello 1.19 } elsif (exists $overrides{$parmKey}) {
1681 :     # Here the value is being overridden, so we skip it for now.
1682 :     @values = ();
1683 : parrello 1.3 }
1684 :     # If we still have values, create the URL parameters.
1685 :     if (@values) {
1686 :     push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1687 :     }
1688 :     }
1689 : parrello 1.19 # Now do the overrides.
1690 :     for my $overKey (keys %overrides) {
1691 :     # Only use this override if it's not a delete marker.
1692 :     if (defined $overrides{$overKey}) {
1693 :     push @urlList, "$overKey=" . uri_escape($overrides{$overKey});
1694 :     }
1695 :     }
1696 : parrello 1.3 # Add the parameters to the URL.
1697 :     $retVal .= "?" . join(";", @urlList);
1698 :     # Return the result.
1699 :     return $retVal;
1700 :     }
1701 :    
1702 : parrello 1.9 =head3 AdvancedClassList
1703 :    
1704 :     C<< my @classes = SearchHelper::AdvancedClassList(); >>
1705 :    
1706 :     Return a list of advanced class names. This list is used to generate the directory
1707 :     of available searches on the search page.
1708 :    
1709 : parrello 1.34 We do a file search to accomplish this, but to pull it off we need to look at %INC.
1710 : parrello 1.9
1711 :     =cut
1712 :    
1713 :     sub AdvancedClassList {
1714 : parrello 1.34 # Determine the search helper module directory.
1715 :     my $libDirectory = $INC{'SearchHelper.pm'};
1716 :     $libDirectory =~ s/SearchHelper\.pm//;
1717 :     # Read it, keeping only the helper modules.
1718 :     my @modules = grep { /^SH\w+\.pm/ } Tracer::OpenDir($libDirectory, 0);
1719 :     # Convert the file names to search types.
1720 :     my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } @modules;
1721 :     # Return the result in alphabetical order.
1722 : parrello 1.30 return sort @retVal;
1723 : parrello 1.9 }
1724 :    
1725 : parrello 1.16 =head3 SelectionTree
1726 :    
1727 :     C<< my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options); >>
1728 :    
1729 :     Display a selection tree.
1730 :    
1731 :     This method creates the HTML for a tree selection control. The tree is implemented as a set of
1732 :     nested HTML unordered lists. Each selectable element of the tree will contain a radio button. In
1733 :     addition, some of the tree nodes can contain hyperlinks.
1734 :    
1735 :     The tree itself is passed in as a multi-level list containing node names followed by
1736 :     contents. Each content element is a reference to a similar list. The first element of
1737 :     each list may be a hash reference. If so, it should contain one or both of the following
1738 :     keys.
1739 :    
1740 :     =over 4
1741 :    
1742 :     =item link
1743 :    
1744 :     The navigation URL to be popped up if the user clicks on the node name.
1745 :    
1746 :     =item value
1747 :    
1748 :     The form value to be returned if the user selects the tree node.
1749 :    
1750 :     =back
1751 :    
1752 :     The presence of a C<link> key indicates the node name will be hyperlinked. The presence of
1753 :     a C<value> key indicates the node name will have a radio button. If a node has no children,
1754 :     you may pass it a hash reference instead of a list reference.
1755 :    
1756 :     The following example shows the hash for a three-level tree with links on the second level and
1757 :     radio buttons on the third.
1758 :    
1759 :     [ Objects => [
1760 :     Entities => [
1761 :     {link => "../docs/WhatIsAnEntity.html"},
1762 :     Genome => {value => 'GenomeData'},
1763 :     Feature => {value => 'FeatureData'},
1764 :     Contig => {value => 'ContigData'},
1765 :     ],
1766 :     Relationships => [
1767 :     {link => "../docs/WhatIsARelationShip.html"},
1768 :     HasFeature => {value => 'GenomeToFeature'},
1769 :     IsOnContig => {value => 'FeatureToContig'},
1770 :     ]
1771 :     ]
1772 :     ]
1773 :    
1774 :     Note how each leaf of the tree has a hash reference for its value, while the branch nodes
1775 :     all have list references.
1776 :    
1777 :     This next example shows how to set up a taxonomy selection field. The value returned
1778 :     by the tree control will be the taxonomy string for the selected node ready for use
1779 :     in a LIKE-style SQL filter. Only the single branch ending in campylobacter is shown for
1780 :     reasons of space.
1781 :    
1782 :     [ All => [
1783 :     {value => "%"},
1784 :     Bacteria => [
1785 :     {value => "Bacteria%"},
1786 :     Proteobacteria => [
1787 :     {value => "Bacteria; Proteobacteria%"},
1788 :     Epsilonproteobacteria => [
1789 :     {value => "Bacteria; Proteobacteria;Epsilonproteobacteria%"},
1790 :     Campylobacterales => [
1791 :     {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales%"},
1792 :     Campylobacteraceae =>
1793 :     {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales; Campylobacteraceae%"},
1794 :     ...
1795 :     ]
1796 :     ...
1797 :     ]
1798 :     ...
1799 :     ]
1800 :     ...
1801 :     ]
1802 :     ...
1803 :     ]
1804 :     ]
1805 :    
1806 :    
1807 :     This method of tree storage allows the caller to control the order in which the tree nodes
1808 :     are displayed and to completely control value selection and use of hyperlinks. It is, however
1809 :     a bit complicated. Eventually, tree-building classes will be provided to simplify things.
1810 :    
1811 :     The parameters to this method are as follows.
1812 :    
1813 :     =over 4
1814 :    
1815 :     =item cgi
1816 :    
1817 :     CGI object used to generate the HTML.
1818 :    
1819 :     =item tree
1820 :    
1821 :     Reference to a hash describing a tree. See the description above.
1822 :    
1823 :     =item options
1824 :    
1825 :     Hash containing options for the tree display.
1826 :    
1827 :     =back
1828 :    
1829 :     The allowable options are as follows
1830 :    
1831 :     =over 4
1832 :    
1833 :     =item nodeImageClosed
1834 :    
1835 :     URL of the image to display next to the tree nodes when they are collapsed. Clicking
1836 :     on the image will expand a section of the tree. The default is C<../FIG/Html/plus.gif>.
1837 :    
1838 :     =item nodeImageOpen
1839 :    
1840 :     URL of the image to display next to the tree nodes when they are expanded. Clicking
1841 :     on the image will collapse a section of the tree. The default is C<../FIG/Html/minus.gif>.
1842 :    
1843 :     =item style
1844 :    
1845 :     Style to use for the tree. The default is C<tree>. Because the tree style is implemented
1846 :     as nested lists, the key components of this style are the definitions for the C<ul> and
1847 :     C<li> tags. The default style file contains the following definitions.
1848 :    
1849 :     .tree ul {
1850 :     margin-left: 0; padding-left: 22px
1851 :     }
1852 :     .tree li {
1853 :     list-style-type: none;
1854 :     }
1855 :    
1856 :     The default image is 22 pixels wide, so in the above scheme each tree level is indented from its
1857 :     parent by the width of the node image. This use of styles limits the things we can do in formatting
1858 :     the tree, but it has the advantage of vastly simplifying the tree creation.
1859 :    
1860 :     =item name
1861 :    
1862 :     Field name to give to the radio buttons in the tree. The default is C<selection>.
1863 :    
1864 :     =item target
1865 :    
1866 :     Frame target for links. The default is C<_self>.
1867 :    
1868 :     =item selected
1869 :    
1870 :     If specified, the value of the radio button to be pre-selected.
1871 :    
1872 :     =back
1873 :    
1874 :     =cut
1875 :    
1876 :     sub SelectionTree {
1877 :     # Get the parameters.
1878 :     my ($cgi, $tree, %options) = @_;
1879 :     # Get the options.
1880 :     my $optionThing = Tracer::GetOptions({ name => 'selection',
1881 :     nodeImageClosed => '../FIG/Html/plus.gif',
1882 :     nodeImageOpen => '../FIG/Html/minus.gif',
1883 :     style => 'tree',
1884 :     target => '_self',
1885 :     selected => undef},
1886 :     \%options);
1887 :     # Declare the return variable. We'll do the standard thing with creating a list
1888 :     # of HTML lines and rolling them together at the end.
1889 :     my @retVal = ();
1890 :     # Only proceed if the tree is present.
1891 :     if (defined($tree)) {
1892 :     # Validate the tree.
1893 :     if (ref $tree ne 'ARRAY') {
1894 :     Confess("Selection tree is not a list reference.");
1895 :     } elsif (scalar @{$tree} == 0) {
1896 :     # The tree is empty, so we do nothing.
1897 :     } elsif ($tree->[0] eq 'HASH') {
1898 :     Confess("Hash reference found at start of selection tree. The tree as a whole cannot have attributes, only tree nodes.");
1899 :     } else {
1900 :     # Here we have a real tree. Apply the tree style.
1901 :     push @retVal, $cgi->start_div({ class => $optionThing->{style} });
1902 :     # Give us a DIV ID.
1903 :     my $divID = GetDivID($optionThing->{name});
1904 :     # Show the tree.
1905 :     push @retVal, ShowBranch($cgi, "(root)", $divID, $tree, $optionThing, 'block');
1906 :     # Close the DIV block.
1907 :     push @retVal, $cgi->end_div();
1908 :     }
1909 :     }
1910 :     # Return the result.
1911 :     return join("\n", @retVal, "");
1912 :     }
1913 :    
1914 :     =head3 ShowBranch
1915 :    
1916 :     C<< my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType); >>
1917 :    
1918 :     This is a recursive method that displays a branch of the tree.
1919 :    
1920 :     =over 4
1921 :    
1922 :     =item cgi
1923 :    
1924 :     CGI object used to format HTML.
1925 :    
1926 :     =item label
1927 :    
1928 :     Label of this tree branch. It is only used in error messages.
1929 :    
1930 :     =item id
1931 :    
1932 :     ID to be given to this tree branch. The ID is used in the code that expands and collapses
1933 :     tree nodes.
1934 :    
1935 :     =item branch
1936 :    
1937 :     Reference to a list containing the content of the tree branch. The list contains an optional
1938 :     hash reference that is ignored and the list of children, each child represented by a name
1939 :     and then its contents. The contents could by a hash reference (indicating the attributes
1940 :     of a leaf node), or another tree branch.
1941 :    
1942 :     =item options
1943 :    
1944 :     Options from the original call to L</SelectionTree>.
1945 :    
1946 :     =item displayType
1947 :    
1948 :     C<block> if the contents of this list are to be displayed, C<none> if they are to be
1949 :     hidden.
1950 :    
1951 :     =item RETURN
1952 :    
1953 :     Returns one or more HTML lines that can be used to display the tree branch.
1954 :    
1955 :     =back
1956 :    
1957 :     =cut
1958 :    
1959 :     sub ShowBranch {
1960 :     # Get the parameters.
1961 :     my ($cgi, $label, $id, $branch, $options, $displayType) = @_;
1962 :     # Declare the return variable.
1963 :     my @retVal = ();
1964 :     # Start the branch.
1965 :     push @retVal, $cgi->start_ul({ id => $id, style => "display:$displayType" });
1966 :     # Check for the hash and choose the start location accordingly.
1967 :     my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0);
1968 :     # Get the list length.
1969 :     my $i1 = scalar(@{$branch});
1970 :     # Verify we have an even number of elements.
1971 :     if (($i1 - $i0) % 2 != 0) {
1972 :     Trace("Branch elements are from $i0 to $i1.") if T(3);
1973 :     Confess("Odd number of elements in tree branch $label.");
1974 :     } else {
1975 :     # Loop through the elements.
1976 :     for (my $i = $i0; $i < $i1; $i += 2) {
1977 :     # Get this node's label and contents.
1978 :     my ($myLabel, $myContent) = ($branch->[$i], $branch->[$i+1]);
1979 :     # Get an ID for this node's children (if any).
1980 :     my $myID = GetDivID($options->{name});
1981 :     # Now we need to find the list of children and the options hash.
1982 :     # This is a bit ugly because we allow the shortcut of a hash without an
1983 :     # enclosing list. First, we need some variables.
1984 :     my $attrHash = {};
1985 :     my @childHtml = ();
1986 :     my $hasChildren = 0;
1987 :     if (! ref $myContent) {
1988 :     Confess("Invalid tree definition. Scalar found as content of node \"$myLabel\".");
1989 :     } elsif (ref $myContent eq 'HASH') {
1990 :     # Here the node is a leaf and its content contains the link/value hash.
1991 :     $attrHash = $myContent;
1992 :     } elsif (ref $myContent eq 'ARRAY') {
1993 :     # Here the node may be a branch. Its content is a list.
1994 :     my $len = scalar @{$myContent};
1995 :     if ($len >= 1) {
1996 :     # Here the first element of the list could by the link/value hash.
1997 :     if (ref $myContent->[0] eq 'HASH') {
1998 :     $attrHash = $myContent->[0];
1999 :     # If there's data in the list besides the hash, it's our child list.
2000 :     # We can pass the entire thing as the child list, because the hash
2001 :     # is ignored.
2002 :     if ($len > 1) {
2003 :     $hasChildren = 1;
2004 :     }
2005 :     } else {
2006 :     $hasChildren = 1;
2007 :     }
2008 :     # If we have children, create the child list with a recursive call.
2009 :     if ($hasChildren) {
2010 :     Trace("Processing children of $myLabel.") if T(4);
2011 :     push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2012 : parrello 1.27 Trace("Children of $myLabel finished.") if T(4);
2013 : parrello 1.16 }
2014 :     }
2015 :     }
2016 :     # Okay, it's time to pause and take stock. We have the label of the current node
2017 :     # in $myLabel, its attributes in $attrHash, and if it is NOT a leaf node, we
2018 :     # have a child list in @childHtml. If it IS a leaf node, $hasChildren is 0.
2019 :     # Compute the image HTML. It's tricky, because we have to deal with the open and
2020 :     # closed images.
2021 :     my @images = ($options->{nodeImageOpen}, $options->{nodeImageClosed});
2022 :     my $image = $images[$hasChildren];
2023 :     my $prefixHtml = $cgi->img({src => $image, id => "${myID}img"});
2024 :     if ($hasChildren) {
2025 :     # If there are children, we wrap the image in a toggle hyperlink.
2026 :     $prefixHtml = $cgi->a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" },
2027 :     $prefixHtml);
2028 :     }
2029 :     # Now the radio button, if any. Note we use "defined" in case the user wants the
2030 :     # value to be 0.
2031 :     if (defined $attrHash->{value}) {
2032 :     # Due to a glitchiness in the CGI stuff, we have to build the attribute
2033 :     # hash for the "input" method. If the item is pre-selected, we add
2034 :     # "checked => undef" to the hash. Otherwise, we can't have "checked"
2035 :     # at all.
2036 :     my $radioParms = { type => 'radio',
2037 :     name => $options->{name},
2038 :     value => $attrHash->{value},
2039 :     };
2040 :     if (defined $options->{selected} && $options->{selected} eq $attrHash->{value}) {
2041 :     $radioParms->{checked} = undef;
2042 :     }
2043 :     $prefixHtml .= $cgi->input($radioParms);
2044 :     }
2045 :     # Next, we format the label.
2046 :     my $labelHtml = $myLabel;
2047 : parrello 1.27 Trace("Formatting tree node for \"$myLabel\".") if T(4);
2048 : parrello 1.16 # Apply a hyperlink if necessary.
2049 :     if (defined $attrHash->{link}) {
2050 :     $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
2051 :     $labelHtml);
2052 :     }
2053 :     # Finally, roll up the child HTML. If there are no children, we'll get a null string
2054 :     # here.
2055 :     my $childHtml = join("\n", @childHtml);
2056 :     # Now we have all the pieces, so we can put them together.
2057 :     push @retVal, $cgi->li("$prefixHtml$labelHtml$childHtml");
2058 :     }
2059 :     }
2060 :     # Close the tree branch.
2061 :     push @retVal, $cgi->end_ul();
2062 :     # Return the result.
2063 :     return @retVal;
2064 :     }
2065 :    
2066 :     =head3 GetDivID
2067 :    
2068 :     C<< my $idString = SearchHelper::GetDivID($name); >>
2069 :    
2070 :     Return a new HTML ID string.
2071 :    
2072 :     =over 4
2073 :    
2074 :     =item name
2075 :    
2076 :     Name to be prefixed to the ID string.
2077 :    
2078 :     =item RETURN
2079 :    
2080 :     Returns a hopefully-unique ID string.
2081 :    
2082 :     =back
2083 :    
2084 :     =cut
2085 :    
2086 :     sub GetDivID {
2087 :     # Get the parameters.
2088 :     my ($name) = @_;
2089 :     # Compute the ID.
2090 :     my $retVal = "elt_$name$divCount";
2091 :     # Increment the counter to make sure this ID is not re-used.
2092 :     $divCount++;
2093 :     # Return the result.
2094 :     return $retVal;
2095 :     }
2096 :    
2097 : parrello 1.31 =head3 PrintLine
2098 :    
2099 :     C<< $shelp->PrintLine($message); >>
2100 :    
2101 :     Print a line of CGI output. This is used during the operation of the B<Find> method while
2102 :     searching, so the user sees progress in real-time.
2103 :    
2104 :     =over 4
2105 :    
2106 :     =item message
2107 :    
2108 :     HTML text to display.
2109 :    
2110 :     =back
2111 :    
2112 :     =cut
2113 :    
2114 :     sub PrintLine {
2115 :     # Get the parameters.
2116 :     my ($self, $message) = @_;
2117 :     # Send them to the output.
2118 :     print "$message\n";
2119 :     }
2120 :    
2121 : parrello 1.34 =head3 GetHelper
2122 : parrello 1.13
2123 : parrello 1.34 C<< my $shelp = SearchHelper::GetHelper($parm, $type => $className); >>
2124 : parrello 1.1
2125 : parrello 1.34 Return a helper object with the given class name. If no such class exists, an
2126 :     error will be thrown.
2127 : parrello 1.1
2128 :     =over 4
2129 :    
2130 : parrello 1.34 =item parm
2131 : parrello 1.1
2132 : parrello 1.34 Parameter to pass to the constructor. This is a CGI object for a search helper
2133 :     and a search helper object for the result helper.
2134 : parrello 1.3
2135 :     =item type
2136 :    
2137 : parrello 1.34 Type of helper: C<RH> for a result helper and C<SH> for a search helper.
2138 : parrello 1.3
2139 : parrello 1.34 =item className
2140 : parrello 1.3
2141 : parrello 1.34 Class name for the helper object, without the preceding C<SH> or C<RH>. This is
2142 :     identical to what the script expects for the C<Class> or C<ResultType> parameter.
2143 : parrello 1.3
2144 :     =item RETURN
2145 :    
2146 : parrello 1.34 Returns a helper object for the specified class.
2147 : parrello 1.3
2148 :     =back
2149 :    
2150 :     =cut
2151 :    
2152 : parrello 1.34 sub GetHelper {
2153 : parrello 1.3 # Get the parameters.
2154 : parrello 1.34 my ($parm, $type, $className) = @_;
2155 : parrello 1.3 # Declare the return variable.
2156 : parrello 1.34 my $retVal;
2157 :     # Try to create the helper.
2158 :     eval {
2159 :     # Load it into memory. If it's already there nothing will happen here.
2160 :     my $realName = "$type$className";
2161 :     Trace("Requiring helper $realName.") if T(3);
2162 :     require "$realName.pm";
2163 :     Trace("Constructing helper object.") if T(3);
2164 :     # Construct the object.
2165 :     $retVal = eval("$realName->new(\$parm)");
2166 :     # Commit suicide if it didn't work.
2167 :     if (! defined $retVal) {
2168 :     die "Could not find a $type handler of type $className.";
2169 :     }
2170 :     };
2171 :     # Check for errors.
2172 :     if ($@) {
2173 :     Confess("Error retrieving $type$className: $@");
2174 : parrello 1.3 }
2175 :     # Return the result.
2176 :     return $retVal;
2177 :     }
2178 :    
2179 : parrello 1.10 =head3 SaveOrganismData
2180 :    
2181 : parrello 1.36 C<< my ($name, $displayGroup, $domain) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain, $taxonomy); >>
2182 : parrello 1.10
2183 :     Format the name of an organism and the display version of its group name. The incoming
2184 :     data should be the relevant fields from the B<Genome> record in the database. The
2185 :     data will also be stored in the genome cache for later use in posting search results.
2186 :    
2187 :     =over 4
2188 :    
2189 :     =item group
2190 :    
2191 :     Name of the genome's group as it appears in the database.
2192 :    
2193 :     =item genomeID
2194 :    
2195 :     ID of the relevant genome.
2196 :    
2197 :     =item genus
2198 :    
2199 :     Genus of the genome's organism. If undefined or null, it will be assumed the genome is not
2200 :     in the database. In this case, the organism name is derived from the genomeID and the group
2201 :     is automatically the supporting-genomes group.
2202 :    
2203 :     =item species
2204 :    
2205 :     Species of the genome's organism.
2206 :    
2207 :     =item strain
2208 :    
2209 :     Strain of the species represented by the genome.
2210 :    
2211 : parrello 1.32 =item taxonomy
2212 :    
2213 :     Taxonomy of the species represented by the genome.
2214 :    
2215 : parrello 1.10 =item RETURN
2216 :    
2217 : parrello 1.32 Returns a three-element list. The first element is the formatted genome name. The second
2218 :     element is the display name of the genome's group. The third is the genome's domain.
2219 : parrello 1.10
2220 :     =back
2221 :    
2222 :     =cut
2223 :    
2224 :     sub SaveOrganismData {
2225 :     # Get the parameters.
2226 : parrello 1.32 my ($self, $group, $genomeID, $genus, $species, $strain, $taxonomy) = @_;
2227 : parrello 1.10 # Declare the return values.
2228 :     my ($name, $displayGroup);
2229 :     # If the organism does not exist, format an unknown name and a blank group.
2230 :     if (! defined($genus)) {
2231 :     $name = "Unknown Genome $genomeID";
2232 :     $displayGroup = "";
2233 :     } else {
2234 :     # It does exist, so format the organism name.
2235 :     $name = "$genus $species";
2236 :     if ($strain) {
2237 :     $name .= " $strain";
2238 :     }
2239 :     # Compute the display group. This is currently the same as the incoming group
2240 :     # name unless it's the supporting group, which is nulled out.
2241 :     $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2242 : parrello 1.36 Trace("Group = $displayGroup, translated from \"$group\".") if T(4);
2243 : parrello 1.10 }
2244 : parrello 1.32 # Compute the domain from the taxonomy.
2245 :     my ($domain) = split /\s*;\s*/, $taxonomy, 2;
2246 : parrello 1.10 # Cache the group and organism data.
2247 :     my $cache = $self->{orgs};
2248 : parrello 1.32 $cache->{$genomeID} = [$name, $displayGroup, $domain];
2249 : parrello 1.10 # Return the result.
2250 : parrello 1.32 return ($name, $displayGroup, $domain);
2251 : parrello 1.10 }
2252 :    
2253 : parrello 1.16 =head3 ValidateKeywords
2254 :    
2255 :     C<< my $okFlag = $shelp->ValidateKeywords($keywordString, $required); >>
2256 :    
2257 :     Insure that a keyword string is reasonably valid. If it is invalid, a message will be
2258 :     set.
2259 :    
2260 :     =over 4
2261 :    
2262 :     =item keywordString
2263 :    
2264 :     Keyword string specified as a parameter to the current search.
2265 :    
2266 :     =item required
2267 :    
2268 :     TRUE if there must be at least one keyword specified, else FALSE.
2269 :    
2270 :     =item RETURN
2271 :    
2272 :     Returns TRUE if the keyword string is valid, else FALSE. Note that a null keyword string
2273 :     is acceptable if the I<$required> parameter is not specified.
2274 :    
2275 :     =back
2276 :    
2277 :     =cut
2278 :    
2279 :     sub ValidateKeywords {
2280 :     # Get the parameters.
2281 :     my ($self, $keywordString, $required) = @_;
2282 :     # Declare the return variable.
2283 :     my $retVal = 0;
2284 :     my @wordList = split /\s+/, $keywordString;
2285 :     # Right now our only real worry is a list of all minus words. The problem with it is that
2286 :     # it will return an incorrect result.
2287 :     my @plusWords = grep { $_ =~ /^[^\-]/ } @wordList;
2288 :     if (! @wordList) {
2289 :     if ($required) {
2290 :     $self->SetMessage("No search words specified.");
2291 : parrello 1.22 } else {
2292 :     $retVal = 1;
2293 : parrello 1.16 }
2294 :     } elsif (! @plusWords) {
2295 :     $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
2296 :     } else {
2297 :     $retVal = 1;
2298 :     }
2299 :     # Return the result.
2300 :     return $retVal;
2301 :     }
2302 :    
2303 : parrello 1.30 =head3 TuningParameters
2304 :    
2305 :     C<< my $options = $shelp->TuningParameters(%parmHash); >>
2306 :    
2307 :     Retrieve tuning parameters from the CGI query object. The parameter is a hash that maps parameter names
2308 :     to their default values. The parameters and their values will be returned as a hash reference.
2309 :    
2310 :     =over 4
2311 :    
2312 :     =item parmHash
2313 :    
2314 :     Hash mapping parameter names to their default values.
2315 :    
2316 :     =item RETURN
2317 :    
2318 :     Returns a reference to a hash containing the parameter names mapped to their actual values.
2319 :    
2320 :     =back
2321 :    
2322 :     =cut
2323 :    
2324 :     sub TuningParameters {
2325 :     # Get the parameters.
2326 :     my ($self, %parmHash) = @_;
2327 :     # Declare the return variable.
2328 :     my $retVal = {};
2329 :     # Get the CGI Query Object.
2330 :     my $cgi = $self->Q();
2331 :     # Loop through the parameter names.
2332 :     for my $parm (keys %parmHash) {
2333 :     # Get the incoming value for this parameter.
2334 :     my $value = $cgi->param($parm);
2335 :     # Zero might be a valid value, so we do an is-defined check rather than an OR.
2336 :     if (defined($value)) {
2337 :     $retVal->{$parm} = $value;
2338 :     } else {
2339 :     $retVal->{$parm} = $parmHash{$parm};
2340 :     }
2341 :     }
2342 :     # Return the result.
2343 :     return $retVal;
2344 :     }
2345 :    
2346 : parrello 1.34 =head3 GetPreferredAliasType
2347 :    
2348 :     C<< my $type = $shelp->GetPreferredAliasType(); >>
2349 :    
2350 :     Return the preferred alias type for the current session. This information is stored
2351 :     in the C<AliasType> parameter of the CGI query object, and the default is C<FIG>
2352 :     (which indicates the FIG ID).
2353 :    
2354 :     =cut
2355 :    
2356 :     sub GetPreferredAliasType {
2357 :     # Get the parameters.
2358 :     my ($self) = @_;
2359 :     # Determine the preferred type.
2360 :     my $cgi = $self->Q();
2361 :     my $retVal = $cgi->param('AliasType') || 'FIG';
2362 :     # Return it.
2363 :     return $retVal;
2364 :     }
2365 :    
2366 : parrello 1.4 =head2 Virtual Methods
2367 :    
2368 :     =head3 Form
2369 :    
2370 :     C<< my $html = $shelp->Form(); >>
2371 :    
2372 :     Generate the HTML for a form to request a new search.
2373 :    
2374 :     =head3 Find
2375 :    
2376 :     C<< my $resultCount = $shelp->Find(); >>
2377 :    
2378 :     Conduct a search based on the current CGI query parameters. The search results will
2379 :     be written to the session cache file and the number of results will be
2380 :     returned. If the search parameters are invalid, a result count of C<undef> will be
2381 :     returned and a result message will be stored in this object describing the problem.
2382 :    
2383 : parrello 1.34 =cut
2384 :    
2385 :     sub Find {
2386 :     # Get the parameters.
2387 :     my ($self) = @_;
2388 :     $self->Message("Call to pure virtual Find method in helper of type " . ref($self) . ".");
2389 :     return undef;
2390 :     }
2391 :    
2392 : parrello 1.4 =head3 Description
2393 :    
2394 :     C<< my $htmlText = $shelp->Description(); >>
2395 :    
2396 :     Return a description of this search. The description is used for the table of contents
2397 :     on the main search tools page. It may contain HTML, but it should be character-level,
2398 :     not block-level, since the description is going to appear in a list.
2399 :    
2400 :     =cut
2401 :    
2402 : parrello 1.34 sub Description {
2403 : parrello 1.4 # Get the parameters.
2404 : parrello 1.34 my ($self) = @_;
2405 :     $self->Message("Call to pure virtual Description method in helper of type " . ref($self) . ".");
2406 :     return "Unknown search type";
2407 : parrello 1.4 }
2408 : parrello 1.9
2409 : parrello 1.31 =head3 SearchTitle
2410 :    
2411 :     C<< my $titleHtml = $shelp->SearchTitle(); >>
2412 :    
2413 :     Return the display title for this search. The display title appears above the search results.
2414 :     If no result is returned, no title will be displayed. The result should be an html string
2415 :     that can be legally put inside a block tag such as C<h3> or C<p>.
2416 :    
2417 :     =cut
2418 :    
2419 :     sub SearchTitle {
2420 :     # Get the parameters.
2421 :     my ($self) = @_;
2422 :     # Declare the return variable.
2423 : parrello 1.34 my $retVal = "";
2424 : parrello 1.31 # Return it.
2425 :     return $retVal;
2426 :     }
2427 :    
2428 : parrello 1.34 =head3 DefaultColumns
2429 : parrello 1.28
2430 : parrello 1.34 C<< $shelp->DefaultColumns($rhelp); >>
2431 : parrello 1.28
2432 : parrello 1.34 Store the default columns in the result helper. The default action is just to ask
2433 :     the result helper for its default columns, but this may be changed by overriding
2434 :     this method.
2435 : parrello 1.28
2436 :     =over 4
2437 :    
2438 : parrello 1.34 =item rhelp
2439 : parrello 1.28
2440 : parrello 1.34 Result helper object in which the column list should be stored.
2441 : parrello 1.28
2442 :     =back
2443 :    
2444 :     =cut
2445 :    
2446 : parrello 1.34 sub DefaultColumns {
2447 : parrello 1.28 # Get the parameters.
2448 : parrello 1.34 my ($self, $rhelp) = @_;
2449 :     # Get the default columns from the result helper.
2450 :     my @cols = $rhelp->DefaultResultColumns();
2451 :     # Store them back.
2452 :     $rhelp->SetColumns(@cols);
2453 : parrello 1.28 }
2454 :    
2455 : parrello 1.34 =head3 Hint
2456 : parrello 1.32
2457 : parrello 1.37 C<< my $htmlText = SearchHelper::Hint($wikiPage, $hintText); >>
2458 : parrello 1.32
2459 : parrello 1.34 Return the HTML for a small question mark that displays the specified hint text when it is clicked.
2460 :     This HTML can be put in forms to provide a useful hinting mechanism.
2461 : parrello 1.32
2462 :     =over 4
2463 :    
2464 : parrello 1.37 =item wikiPage
2465 :    
2466 :     Name of the wiki page to be popped up when the hint maek is clicked.
2467 :    
2468 : parrello 1.34 =item hintText
2469 : parrello 1.32
2470 : parrello 1.34 Text to display for the hint. It is raw html, but may not contain any double quotes.
2471 : parrello 1.32
2472 :     =item RETURN
2473 :    
2474 : parrello 1.34 Returns the html for the hint facility. The resulting html shows a small button-like thing that
2475 :     uses the standard FIG popup technology.
2476 : parrello 1.32
2477 :     =back
2478 :    
2479 :     =cut
2480 :    
2481 : parrello 1.34 sub Hint {
2482 :     # Get the parameters.
2483 : parrello 1.37 my ($wikiPage, $hintText) = @_;
2484 :     # Escape the single quotes in the hint text.
2485 : parrello 1.34 my $quotedText = $hintText;
2486 :     $quotedText =~ s/'/\\'/g;
2487 : parrello 1.37 # Convert the wiki page name to a URL.
2488 :     my $wikiURL = ucfirst $wikiPage;
2489 :     $wikiURL =~ s/ /_/g;
2490 :     $wikiURL = "../wiki/index.php/$wikiURL";
2491 : parrello 1.34 # Create the html.
2492 :     my $retVal = "&nbsp;<input type=\"button\" class=\"hintbutton\" onMouseOver=\"javascript:if (!this.tooltip) { " .
2493 :     "this.tooltip = new Popup_Tooltip(this, 'Search Hint', '$quotedText', '', 1); this.tooltip.addHandler(); } " .
2494 : parrello 1.37 "return false;\" value=\"?\" onClick=\"javascript:window.open('$wikiURL', 'nmpdrHelp');\" />";
2495 : parrello 1.34 # Return it.
2496 :     return $retVal;
2497 : parrello 1.32 }
2498 :    
2499 :    
2500 : parrello 1.1 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3