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

Annotation of /Sprout/SearchHelper.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3