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

Diff of /Sprout/SearchHelper.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1, Tue Sep 26 13:46:03 2006 UTC revision 1.47, Mon Mar 16 00:23:37 2009 UTC
# Line 10  Line 10 
10      use File::Path;      use File::Path;
11      use File::stat;      use File::stat;
12      use LWP::UserAgent;      use LWP::UserAgent;
13      use Time::HiRes 'gettimeofday';      use FIGRules;
14      use Sprout;      use Sprout;
15      use SFXlate;      use SFXlate;
16      use FIGRules;      use FIGRules;
17      use HTML;      use HTML;
18      use BasicLocation;      use BasicLocation;
19        use URI::Escape;
20        use PageBuilder;
21        use AliasAnalysis;
22        use CGI::Cookie;
23        use FreezeThaw qw(freeze thaw);
24    
25  =head1 Search Helper Base Class  =head1 Search Helper Base Class
26    
# Line 62  Line 67 
67    
68  =item orgs  =item orgs
69    
70  Reference to a hash mapping genome IDs to organism names.  Reference to a hash mapping genome IDs to organism data. (Used to
71    improve performance.)
72    
73  =item name  =item name
74    
# Line 72  Line 78 
78    
79  List of JavaScript statements to be executed after the form is closed.  List of JavaScript statements to be executed after the form is closed.
80    
81    =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    =item notices
90    
91    A list of messages to be put in the notice file.
92    
93    =back
94    
95    =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    name of the subclass must be C<SH>I<className>, where I<className> is the
109    type of search.
110    
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    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    
123  =back  =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    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    
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    The L</Find> method is used to create the search results. The basic code
175    structure would work as follows.
176    
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            } else {
189                # Determine the result type.
190                my $rhelp = SearchHelper::GetHelper($self, RH => $resultType);
191                # Specify the columns.
192                $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                # Initialize the session file.
204                $self->OpenSession($rhelp);
205                # Initialize the result counter.
206                $retVal = 0;
207                ... 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                }
213                # Close the session file.
214                $self->CloseSession();
215            }
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    are variations on the above theme.
222    
223    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    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  =cut  =cut
239    
240  # This counter is used to insure every form on the page has a unique name.  # This counter is used to insure every form on the page has a unique name.
241  my $formCount = 0;  my $formCount = 0;
242    # This counter is used to generate unique DIV IDs.
243    my $divCount = 0;
244    
245  =head2 Public Methods  =head2 Public Methods
246    
247  =head3 new  =head3 new
248    
249  C<< my $shelp = SearchHelper->new($query); >>      my $shelp = SearchHelper->new($cgi);
250    
251  Construct a new SearchHelper object.  Construct a new SearchHelper object.
252    
253  =over 4  =over 4
254    
255  =item query  =item cgi
256    
257  The CGI query object for the current script.  The CGI query object for the current script.
258    
# Line 99  Line 262 
262    
263  sub new {  sub new {
264      # Get the parameters.      # Get the parameters.
265      my ($class, $query) = @_;      my ($class, $cgi) = @_;
266      # Check for a session ID.      # Check for a session ID. First we look in the CGI parameters.
267      my $session_id = $query->param("SessionID");      my $session_id = $cgi->param("SessionID");
268      my $type = "old";      my $type = "old";
269      if (! $session_id) {      if (! $session_id) {
270            # 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          # Here we're starting a new session. We create the session ID and
276          # store it in the query object.              # store it in a cookie.
277          $session_id = NewSessionID();              $session_id = FIGRules::NewSessionID();
278                Trace("New session ID is $session_id.") if T(3);
279                $session_cookie = new CGI::Cookie(-name => $class,
280                                                  -value => $session_id);
281                $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          $type = "new";          $type = "new";
291          $query->param(-name => 'SessionID', -value => $session_id);          # Put the session ID in the parameters.
292            $cgi->param(-name => 'SessionID', -value => $session_id);
293        } else {
294            Trace("Session ID is $session_id.") if T(3);
295      }      }
296        Trace("Computing subclass.") if T(3);
297      # Compute the subclass name.      # Compute the subclass name.
298      $class =~ /SH(.+)$/;      my $subClass;
299      my $subClass = $1;      if ($class =~ /SH(.+)$/) {
300      # Create the Sprout object.          # Here we have a real search class.
301      my $sprout = SFXlate->new_sprout_only();          $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        Trace("Subclass name is $subClass.") if T(3);
308      # Insure everybody knows we're in Sprout mode.      # Insure everybody knows we're in Sprout mode.
309      $query->param(-name => 'SPROUT', -value => 1);      $cgi->param(-name => 'SPROUT', -value => 1);
310      # Generate the form name.      # Generate the form name.
311      my $formName = "$class$formCount";      my $formName = "$class$formCount";
312      $formCount++;      $formCount++;
313        Trace("Creating helper.") if T(3);
314      # Create the shelp object. It contains the query object (with the session ID)      # 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      # as well as an indicator as to whether or not the session is new, plus the
316      # class name and the Sprout object.      # class name and a placeholder for the Sprout object.
317      my $retVal = {      my $retVal = {
318                    query => $query,                    query => $cgi,
319                    type => $type,                    type => $type,
320                    class => $subClass,                    class => $subClass,
321                    sprout => $sprout,                    sprout => undef,
322                    orgs => {},                    orgs => {},
323                    name => $formName,                    name => $formName,
324                    scriptQueue => [],                    scriptQueue => [],
325                      genomeList => undef,
326                      genomeParms => [],
327                      notices => [],
328                   };                   };
329      # Bless and return it.      # Bless and return it.
330      bless $retVal, $class;      bless $retVal, $class;
# Line 139  Line 333 
333    
334  =head3 Q  =head3 Q
335    
336  C<< my $query = $shelp->Q(); >>      my $query = $shelp->Q();
337    
338  Return the CGI query object.  Return the CGI query object.
339    
# Line 152  Line 346 
346      return $self->{query};      return $self->{query};
347  }  }
348    
349    
350  =head3 DB  =head3 DB
351    
352  C<< my $sprout = $shelp->DB(); >>      my $sprout = $shelp->DB();
353    
354  Return the Sprout database object.  Return the Sprout database object.
355    
# Line 163  Line 358 
358  sub DB {  sub DB {
359      # Get the parameters.      # Get the parameters.
360      my ($self) = @_;      my ($self) = @_;
361        # 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      # Return the result.      # Return the result.
368      return $self->{sprout};      return $retVal;
369  }  }
370    
371  =head3 IsNew  =head3 IsNew
372    
373  C<< my $flag = $shelp->IsNew(); >>      my $flag = $shelp->IsNew();
374    
375  Return TRUE if this is a new session, FALSE if this is an old session. An old  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.  session already has search results ready to process.
# Line 185  Line 386 
386    
387  =head3 ID  =head3 ID
388    
389  C<< my $sessionID = $shelp->ID(); >>      my $sessionID = $shelp->ID();
390    
391  Return the current session ID.  Return the current session ID.
392    
# Line 200  Line 401 
401    
402  =head3 FormName  =head3 FormName
403    
404  C<< my $name = $shelp->FormName(); >>      my $name = $shelp->FormName();
405    
406  Return the name of the form this helper object will generate.  Return the name of the form this helper object will generate.
407    
# Line 215  Line 416 
416    
417  =head3 QueueFormScript  =head3 QueueFormScript
418    
419  C<< $shelp->QueueFormScript($statement); >>      $shelp->QueueFormScript($statement);
420    
421  Add the specified statement to the queue of JavaScript statements that are to be  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  executed when the form has been fully defined. This is necessary because until
# Line 250  Line 451 
451    
452  =head3 FormStart  =head3 FormStart
453    
454  C<< my $html = $shelp->FormStart($title); >>      my $html = $shelp->FormStart($title);
455    
456  Return the initial section of a form designed to perform another search of the  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  same type. The form header is included along with hidden fields to persist the
# Line 277  Line 478 
478      my ($self, $title) = @_;      my ($self, $title) = @_;
479      # Get the CGI object.      # Get the CGI object.
480      my $cgi = $self->Q();      my $cgi = $self->Q();
481      # Start the form.      # Start the form. Note we use the override option on the Class value, in
482        # case the Advanced button was used.
483      my $retVal = "<div class=\"search\">\n" .      my $retVal = "<div class=\"search\">\n" .
484                   $cgi->start_form(-method => 'POST',                   CGI::start_form(-method => 'POST',
485                                    -action => $cgi->url(-relative => 1),                                    -action => "$FIG_Config::cgi_url/wiki/rest.cgi/NmpdrPlugin/search",
486                                    -name => $self->FormName()) .                                    -name => $self->FormName(),
487                   $cgi->hidden(-name => 'Class',                                    -id => $self->FormName()) .
488                     CGI::hidden(-name => 'Class',
489                                -value => $self->{class}) .                                -value => $self->{class}) .
490                   $cgi->hidden(-name => 'SPROUT',                   CGI::hidden(-name => 'SPROUT',
491                                -value => 1) .                                -value => 1) .
492                   $cgi->h3($title);                   CGI::h3("$title" . Hint($self->{class}));
     # If tracing is on, add it to the form.  
     if ($cgi->param('Trace')) {  
         $retVal .= $cgi->hidden(-name => 'Trace',  
                                 -value => $cgi->param('Trace')) .  
                    $cgi->hidden(-name => 'TF',  
                                 -value => ($cgi->param('TF') ? 1 : 0));  
     }  
493      # Put in an anchor tag in case there's a table of contents.      # Put in an anchor tag in case there's a table of contents.
494      my $anchorName = $self->FormName();      my $anchorName = $self->FormName();
495      $retVal .= "<a name=\"$anchorName\"></a>\n";      $retVal .= "<a name=\"$anchorName\"></a>\n";
# Line 303  Line 499 
499    
500  =head3 FormEnd  =head3 FormEnd
501    
502  C<< my $htmlText = $shelp->FormEnd(); >>      my $htmlText = $shelp->FormEnd();
503    
504  Return the HTML text for closing a search form. This closes both the C<form> and  Return the HTML text for closing a search form. This closes both the C<form> and
505  C<div> tags.  C<div> tags.
# Line 335  Line 531 
531    
532  =head3 SetMessage  =head3 SetMessage
533    
534  C<< $shelp->SetMessage($msg); >>      $shelp->SetMessage($msg);
535    
536  Store the specified text as the result message. The result message is displayed  Store the specified text as the result message. The result message is displayed
537  if an invalid parameter value is specified.  if an invalid parameter value is specified.
# Line 359  Line 555 
555    
556  =head3 Message  =head3 Message
557    
558  C<< my $text = $shelp->Message(); >>      my $text = $shelp->Message();
559    
560  Return the result message. The result message is displayed if an invalid parameter  Return the result message. The result message is displayed if an invalid parameter
561  value is specified.  value is specified.
# Line 375  Line 571 
571    
572  =head3 OpenSession  =head3 OpenSession
573    
574  C<< $shelp->OpenSession(); >>      $shelp->OpenSession($rhelp);
575    
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    
587  Set up to open the session cache file for writing. Note we don't actually  =back
 open the file until after we know the column headers.  
588    
589  =cut  =cut
590    
591  sub OpenSession {  sub OpenSession {
592      # Get the parameters.      # Get the parameters.
593      my ($self) = @_;      my ($self, $rhelp) = @_;
594      # Denote we have not yet written out the column headers.      # Insure the result helper is valid.
595      $self->{cols} = undef;      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  }  }
606    
607  =head3 GetCacheFileName  =head3 GetCacheFileName
608    
609  C<< my $fileName = $shelp->GetCacheFileName(); >>      my $fileName = $shelp->GetCacheFileName();
610    
611  Return the name to be used for this session's cache file.  Return the name to be used for this session's cache file.
612    
# Line 406  Line 621 
621    
622  =head3 GetTempFileName  =head3 GetTempFileName
623    
624  C<< my $fileName = $shelp->GetTempFileName($type); >>      my $fileName = $shelp->GetTempFileName($type);
625    
626  Return the name to be used for a temporary file of the specified type. The  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.  name is computed from the session name with the type as a suffix.
# Line 430  Line 645 
645      my ($self, $type) = @_;      my ($self, $type) = @_;
646      # Compute the file name. Note it gets stuffed in the FIG temporary      # Compute the file name. Note it gets stuffed in the FIG temporary
647      # directory.      # directory.
648      my $retVal = "$FIG_Config::temp/tmp_" . $self->ID() . ".$type";      my $retVal = FIGRules::GetTempFileName(sessionID => $self->ID(), extension => $type);
649      # Return the result.      # Return the result.
650      return $retVal;      return $retVal;
651  }  }
652    
653  =head3 PutFeature  =head3 WriteColumnHeaders
654    
655        $shelp->WriteColumnHeaders(@colNames);
656    
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  C<< $shelp->PutFeature($record, %extraCols); >>  =over 4
662    
663  Store a feature in the result cache. This is the workhorse method for most  =item colNames
 searches, since the primary data item in the database is features.  
664    
665  For each feature, there are certain columns that are standard: the feature name, the  A list of column names in the desired presentation order. For extra columns,
666  GBrowse and protein page links, the functional assignment, and so forth. If additional  the column name is the hash supplied as the column definition.
 columns are required by a particular search subclass, they should be included in the  
 parameters, in key-value form. For example, the following call adds columns for  
 essentiality and virulence.  
667    
668      $shelp->PutFeature($record, essential => $essentialFlag, virulence => $vfactor);  =back
669    
670  For correct results, all values should be specified for all extra columns in all calls to  =cut
 B<PutFeature>. (In particular, the column header names are computed on the first  
 call.) If a column is to be blank for the current feature, its value can be given  
 as C<undef>.  
671    
672      if (! $essentialFlag) {  sub WriteColumnHeaders {
673          $essentialFlag = undef;      # 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        # Freeze the column headers.
679        my @colHdrs = map { freeze($_) } @colNames;
680        # Write the column headers and close the file.
681        Tracer::PutLine($handle1, \@colHdrs);
682        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      }      }
     $shelp->PutFeature($record, essential => $essentialFlag, virulence = $vfactor);  
689    
690  =over 4  =head3 SetNotice
691    
692  =item record      $shelp->SetNotice($message);
693    
694  DBObject record for the feature.  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  =item extraCols  Message to write to the notice file.
703    
704  =back  =back
705    
706  =cut  =cut
707    
708  sub PutFeature {  sub SetNotice {
709      # Get the parameters. Note that the extra columns are read in as a list      # Get the parameters.
710      # instead of a hash so that the column order is preserved.      my ($self, $message) = @_;
711      my ($self, $record, @extraColList) = @_;      # Save the message.
712      # Check for a first-call situation.      push @{$self->{notices}}, $message;
     if (! defined $self->{cols}) {  
         # Here we need to set up the column information. Start with the defaults.  
         $self->{cols} = $self->DefaultFeatureColumns();  
         # Append the extras. Note we proceed by twos because the columns are  
         # specified in the form name => value.  
         for (my $i = 0; $i <= $#extraColList; $i += 2) {  
             push @{$self->{cols}}, "X=$extraColList[$i]";  
         }  
         # Write out the column headers. This also prepares the cache file to receive  
         # output.  
         $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});  
     }  
     # Get the feature ID.  
     my ($fid) = $record->Value('Feature(id)');  
     # Now we process the columns themselves. First, convert the extra column list  
     # to a hash.  
     my %extraCols = @extraColList;  
     # Loop through the column headers, producing the desired data.  
     my @output = ();  
     for my $colName (@{$self->{cols}}) {  
         push @output, $self->FeatureColumnValue($colName, $record, \%extraCols);  
     }  
     # Compute the sort key. The sort key floats NMPDR organism features to the  
     # top of the return list.  
     my $group = $self->FeatureGroup($fid);  
     my $key = ($group ? "A$group" : "ZZ");  
     # Write the feature data.  
     $self->WriteColumnData($key, @output);  
713  }  }
714    
 =head3 WriteColumnHeaders  
715    
716  C<< $shelp->WriteColumnHeaders(@colNames); >>  =head3 ReadColumnHeaders
717    
718  Write out the column headers for the current search session. The column headers      my @colHdrs = $shelp->ReadColumnHeaders($fh);
719  are sent to the cache file, and then the cache is re-opened as a sort pipe and  
720  the handle saved.  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  =over 4
726    
727  =item colNames  =item fh
728    
729    File handle from which the column headers are to be read.
730    
731    =item RETURN
732    
733  A list of column names in the desired presentation order.  Returns a list of the column headers pulled from the specified file's first line.
734    
735  =back  =back
736    
737  =cut  =cut
738    
739  sub WriteColumnHeaders {  sub ReadColumnHeaders {
740      # Get the parameters.      # Get the parameters.
741      my ($self, @colNames) = @_;      my ($self, $fh) = @_;
742      # Get the cache file name and open it for output.      # Read and thaw the columns.
743      my $fileName = $self->GetCacheFileName();      my @retVal = map { thaw($_) } Tracer::GetLine($fh);
744      my $handle1 = Open(undef, ">$fileName");      # Return them to the caller.
745      # Write the column headers and close the file.      return @retVal;
     Tracer::PutLine($handle1, \@colNames);  
     close $handle1;  
     # Now open the sort pipe and save the file handle. Note how we append the  
     # sorted data to the column header row already in place. The output will  
     # contain a sort key followed by the real columns. The sort key is  
     # hacked off before going to the output file.  
     $self->{fileHandle} = Open(undef, "| sort | cut --fields=2- >>$fileName");  
746  }  }
747    
748  =head3 WriteColumnData  =head3 WriteColumnData
749    
750  C<< $shelp->WriteColumnData($key, @colValues); >>      $shelp->WriteColumnData($key, @colValues);
751    
752  Write a row of column values to the current search session. It is assumed that  Write a row of column values to the current search session. It is assumed that
753  the session file is already open for output.  the session file is already open for output.
# Line 567  Line 771 
771      my ($self, $key, @colValues) = @_;      my ($self, $key, @colValues) = @_;
772      # Write them to the cache file.      # Write them to the cache file.
773      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);
774        Trace("Column data is " . join("; ", $key, @colValues) . ".") if T(4);
775  }  }
776    
777  =head3 CloseSession  =head3 CloseSession
778    
779  C<< $shelp->CloseSession(); >>      $shelp->CloseSession();
780    
781  Close the session file.  Close the session file.
782    
# Line 583  Line 788 
788      # Check for an open session file.      # Check for an open session file.
789      if (defined $self->{fileHandle}) {      if (defined $self->{fileHandle}) {
790          # We found one, so close it.          # We found one, so close it.
791            Trace("Closing session file.") if T(2);
792          close $self->{fileHandle};          close $self->{fileHandle};
793            # Tell the user.
794            my $cgi = $self->Q();
795            $self->PrintLine("Output formatting complete.<br />");
796      }      }
797        # 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  }  }
   
 =head3 NewSessionID  
   
 C<< my $id = SearchHelpers::NewSessionID(); >>  
   
 Generate a new session ID for the current user.  
   
 =cut  
   
 sub NewSessionID {  
     # Declare the return variable.  
     my $retVal;  
     # Get a digest encoder.  
     my $md5 = Digest::MD5->new();  
     # If we have a randomization file, use it to seed the digester.  
     if (open(R, "/dev/urandom")) {  
         my $b;  
         read(R, $b, 1024);  
         $md5->add($b);  
     }  
     # Add the PID and the time stamp.  
     $md5->add($$, gettimeofday);  
     # Hash it up and clean the result so that it works as a file name.  
     $retVal = $md5->b64digest();  
     $retVal =~ s,/,\$,g;  
     $retVal =~ s,\+,@,g;  
     # Return it.  
     return $retVal;  
807  }  }
808    
809  =head3 OrganismData  =head3 OrganismData
810    
811  C<< my ($orgName, $group) = $shelp->Organism($genomeID); >>      my ($orgName, $group) = $shelp->Organism($genomeID);
812    
813  Return the name and status of the organism corresponding to the specified genome ID.  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  For performance reasons, this information is cached in a special hash table, so we
# Line 632  Line 822 
822    
823  =item RETURN  =item RETURN
824    
825  Returns a list of two items. The first item in the list is the organism name,  Returns a list of three items. The first item in the list is the organism name,
826  and the second is the name of the NMPDR group, or an empty string if the  and the second is the name of the NMPDR group, or an empty string if the
827  organism is not in an NMPDR group.  organism is not in an NMPDR group. The third item is the organism's domain.
828    
829  =back  =back
830    
# Line 644  Line 834 
834      # Get the parameters.      # Get the parameters.
835      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
836      # Declare the return variables.      # Declare the return variables.
837      my ($orgName, $group);      my ($orgName, $group, $domain);
838      # Check the cache.      # Check the cache.
839      my $cache = $self->{orgs};      my $cache = $self->{orgs};
840      if (exists $cache->{$genomeID}) {      if (exists $cache->{$genomeID}) {
841          ($orgName, $group) = @{$cache->{$genomeID}};          ($orgName, $group, $domain) = @{$cache->{$genomeID}};
842            Trace("Cached organism $genomeID has group \"$group\".") if T(4);
843      } else {      } else {
844          # Here we have to use the database.          # Here we have to use the database.
845          my $sprout = $self->DB();          my $sprout = $self->DB();
846          my ($genus, $species, $strain, $group) = $sprout->GetEntityValues('Genome', $genomeID,          my ($genus, $species, $strain, $newGroup, $taxonomy) = $sprout->GetEntityValues('Genome', $genomeID,
847                                                      ['Genome(genus)', 'Genome(species)',                                                      ['Genome(genus)', 'Genome(species)',
848                                                       'Genome(unique-characterization)',                                                       'Genome(unique-characterization)',
849                                                       'Genome(primary-group)']);                                                                   'Genome(primary-group)',
850          # Null out the supporting group.                                                                   'Genome(taxonomy)']);
851          $group = "" if ($group eq $FIG_Config::otherGroup);          # Format and cache the name and display group.
852          # If the organism does not exist, format an unknown name.          Trace("Caching organism $genomeID with group \"$newGroup\".") if T(4);
853          if (! defined($genus)) {          ($orgName, $group, $domain) = $self->SaveOrganismData($newGroup, $genomeID, $genus, $species,
854              $orgName = "Unknown Genome $genomeID";                                                                $strain, $taxonomy);
855          } else {          Trace("Returning group $group.") if T(4);
             # It does exist, so format the organism name.  
             $orgName = "$genus $species";  
             if ($strain) {  
                 $orgName .= " $strain";  
             }  
         }  
         # Save this organism in the cache.  
         $cache->{$genomeID} = [$orgName, $group];  
856      }      }
857      # Return the result.      # Return the result.
858      return ($orgName, $group);      return ($orgName, $group, $domain);
859  }  }
860    
861  =head3 Organism  =head3 Organism
862    
863  C<< my $orgName = $shelp->Organism($genomeID); >>      my $orgName = $shelp->Organism($genomeID);
864    
865  Return the name of the relevant organism. The name is computed from the genus,  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.  species, and unique characterization. A cache is used to improve performance.
# Line 700  Line 883 
883      # Get the parameters.      # Get the parameters.
884      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
885      # Get the organism data.      # Get the organism data.
886      my ($retVal, $group) = $self->OrganismData($genomeID);      my ($retVal) = $self->OrganismData($genomeID);
     # Return the result.  
     return $retVal;  
 }  
   
 =head3 FeatureGroup  
   
 C<< my $groupName = $shelp->FeatureGroup($fid); >>  
   
 Return the group name for the specified feature.  
   
 =over 4  
   
 =item fid  
   
 ID of the relevant feature.  
   
 =item RETURN  
   
 Returns the name of the NMPDR group to which the feature belongs, or an empty  
 string if it is not part of an NMPDR group.  
   
 =back  
   
 =cut  
   
 sub FeatureGroup {  
     # Get the parameters.  
     my ($self, $fid) = @_;  
     # Parse the feature ID to get the genome ID.  
     my ($genomeID) = FIGRules::ParseFeatureID($fid);  
     # Get the organism data.  
     my (undef, $retVal) = $self->OrganismData($genomeID);  
     # Return the result.  
     return $retVal;  
 }  
   
 =head3 FeatureName  
   
 C<< my $fidName = $shelp->FeatureName($fid); >>  
   
 Return the display name of the specified feature.  
   
 =over 4  
   
 =item fid  
   
 ID of the feature whose name is desired.  
   
 =item RETURN  
   
 A displayable feature name, consisting of the organism name plus some feature  
 type and location information.  
   
 =back  
   
 =cut  
   
 sub FeatureName {  
     # Get the parameters.  
     my ($self, $fid) = @_;  
     # Declare the return variable  
     my $retVal;  
     # Parse the feature ID.  
     my ($genomeID, $type, $num) = FIGRules::ParseFeatureID($fid);  
     if (! defined $genomeID) {  
         # Here the feature ID has an invalid format.  
         $retVal = "External: $fid";  
     } else {  
         # Here we can get its genome data.  
         $retVal = $self->Organism($genomeID);  
         # Append the type and number.  
         $retVal .= " [$type $num]";  
     }  
887      # Return the result.      # Return the result.
888      return $retVal;      return $retVal;
889  }  }
890    
891  =head3 ComputeFASTA  =head3 ComputeFASTA
892    
893  C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >>      my $fasta = $shelp->ComputeFASTA($desiredType, $sequence, $flankingWidth, $comments);
894    
895  Parse a sequence input and convert it into a FASTA string of the desired type. Note  Parse a sequence input and convert it into a FASTA string of the desired type with
896  that it is possible to convert a DNA sequence into a protein sequence, but the reverse  the desired flanking width.
 is not possible.  
897    
898  =over 4  =over 4
899    
 =item incomingType  
   
 C<dna> if this is a DNA sequence, C<prot> if this is a protein sequence.  
   
900  =item desiredType  =item desiredType
901    
902  C<dna> to return a DNA sequence, C<prot> to return a protein sequence. If the  C<dna> to return a DNA sequence, C<prot> to return a protein sequence, C<dnaPattern>
903  I<$incomingType> is C<prot> and this value is C<dna>, an error will be thrown.  to return a DNA search pattern, C<protPattern> to return a protein search pattern.
904    
905  =item sequence  =item sequence
906    
# Line 805  Line 910 
910  if the input does not begin with a greater-than sign (FASTA label line), a default label  if the input does not begin with a greater-than sign (FASTA label line), a default label
911  line will be provided.  line will be provided.
912    
913    =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    =item comments
921    
922    Comment string to be added to the FASTA header.
923    
924  =item RETURN  =item RETURN
925    
926  Returns a string in FASTA format representing the content of the desired sequence with  Returns a string in FASTA format representing the content of the desired sequence with
# Line 817  Line 933 
933    
934  sub ComputeFASTA {  sub ComputeFASTA {
935      # Get the parameters.      # Get the parameters.
936      my ($self, $incomingType, $desiredType, $sequence) = @_;      my ($self, $desiredType, $sequence, $flankingWidth, $comment) = @_;
937      # Declare the return variable. If an error occurs, it will remain undefined.      # Declare the return variable. If an error occurs, it will remain undefined.
938      my $retVal;      my $retVal;
939        # This variable will be cleared if an error is detected.
940        my $okFlag = 1;
941      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
942      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
943      # Check for a feature specification.      Trace("FASTA desired type is $desiredType.") if T(4);
944        # Check for a feature specification. The smoking gun for that is a vertical bar.
945      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
946          # Here we have a feature ID in $1. We'll need the Sprout object to process          # Here we have a feature ID in $1. We'll need a Sprout object to process it.
         # it.  
947          my $fid = $1;          my $fid = $1;
948            Trace("Feature ID for fasta is $fid.") if T(3);
949          my $sprout = $self->DB();          my $sprout = $self->DB();
950          # Get the FIG ID. Note that we only use the first feature found. We are not          # 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          # supposed to have redundant aliases, though we may have an ID that doesn't
952          # exist.          # exist.
953          my ($figID) = $sprout->FeaturesByAlias($fid);          my ($figID) = $sprout->FeaturesByAlias($fid);
954          if (! $figID) {          if (! $figID) {
955              $self->SetMessage("No feature found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
956                $okFlag = 0;
957          } else {          } else {
958              # Set the FASTA label.              # Set the FASTA label. The ID is the first favored alias.
959              my $fastaLabel = $fid;              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                # Add any specified comments.
967                if ($comment) {
968                    $fastaLabel .= " $comment";
969                }
970              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
971              if ($desiredType =~ /prot/i) {              if ($desiredType =~ /prot/) {
972                  # We want protein, so get the translation.                  # We want protein, so get the translation.
973                  $fastaData = $sprout->FeatureTranslation($figID);                  $fastaData = $sprout->FeatureTranslation($figID);
974              } else {                  Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
975                  # We want DNA, so get the DNA sequence. This is a two-step process.              } elsif ($desiredType =~ /dna/) {
976                    # We want DNA, so get the DNA sequence. This is a two-step process. First, we get the
977                    # locations.
978                  my @locList = $sprout->FeatureLocation($figID);                  my @locList = $sprout->FeatureLocation($figID);
979                    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);                  $fastaData = $sprout->DNASeq(\@locList);
1009              }              }
1010                    Trace((length $fastaData) . " characters returned for DNA of $fastaLabel.") if T(3);
1011                }
1012          }          }
     } elsif ($incomingType =~ /prot/ && $desiredType =~ /dna/) {  
         # Here we're being asked to do an impossible conversion.  
         $self->SetMessage("Cannot convert a protein sequence to DNA.");  
1013      } else {      } else {
1014            Trace("Analyzing FASTA sequence.") if T(4);
1015          # Here we are expecting a FASTA. We need to see if there's a label.          # Here we are expecting a FASTA. We need to see if there's a label.
1016          if ($sequence =~ /^>\s*(\S.*)\s*\n(.+)$/) {          if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) {
1017                Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4);
1018              # Here we have a label, so we split it from the data.              # Here we have a label, so we split it from the data.
1019              $fastaLabel = $1;              $fastaLabel = $1;
1020              $fastaData = $2;              $fastaData = $2;
1021          } else {          } else {
1022                Trace("No label found in match to sequence:\n$sequence") if T(4);
1023              # Here we have no label, so we create one and use the entire sequence              # Here we have no label, so we create one and use the entire sequence
1024              # as data.              # as data.
1025              $fastaLabel = "User-specified $incomingType sequence";              $fastaLabel = "$desiredType sequence specified by user";
1026              $fastaData = $sequence;              $fastaData = $sequence;
1027          }          }
1028          # The next step is to clean the junk out of the sequence.          # 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;          $fastaData =~ s/\n//g;
1031          $fastaData =~ s/\s+//g;          $fastaData =~ s/\s+//g;
1032          # Finally, if the user wants to convert to protein, we do it here. Note that              $fastaData =~ s/\d+//g;
1033          # we've already prevented a conversion from protein to DNA.          }
1034          if ($incomingType ne $desiredType) {          # Finally, verify that it's DNA if we're doing DNA stuff.
1035              $fastaData = Sprout::Protein($fastaData);          if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn-]/i) {
1036                $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?");
1037                $okFlag = 0;
1038          }          }
1039      }      }
1040      # At this point, either "$fastaLabel" and "$fastaData" have values or an error is      Trace("FASTA data sequence: $fastaData") if T(4);
1041      # in progress.      # Only proceed if no error was detected.
1042      if (defined $fastaLabel) {      if ($okFlag) {
1043            if ($desiredType =~ /pattern/i) {
1044                # For a scan, there is no label and no breakup.
1045                $retVal = $fastaData;
1046            } else {
1047          # We need to format the sequence into 60-byte chunks. We use the infamous          # 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,          # 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          # 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          # the empty list items that appear between the so-called delimiters, since
1051          # the delimiters are what we want.          # the delimiters are what we want.
1052          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
1053          my $retVal = join("\n", ">$fastaLabel", @chunks, "");              $retVal = join("\n", ">$fastaLabel", @chunks, "");
1054            }
1055      }      }
1056      # Return the result.      # Return the result.
1057      return $retVal;      return $retVal;
1058  }  }
1059    
1060    =head3 SubsystemTree
1061    
1062        my $tree = SearchHelper::SubsystemTree($sprout, %options);
1063    
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        # 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        # 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        # 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        push @subs, ['', undef];
1141        # 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                    $nodeContent->{link} = "$svURL?page=Subsystems;subsystem=$linkable";
1198                }
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  =head3 NmpdrGenomeMenu  =head3 NmpdrGenomeMenu
1214    
1215  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, \%options, \@selected); >>      my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows);
1216    
1217  This method creates a hierarchical HTML menu for NMPDR genomes organized by category. The  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  category indicates the low-level NMPDR group. Organizing the genomes in this way makes it
# Line 900  Line 1224 
1224    
1225  Name to give to the menu.  Name to give to the menu.
1226    
1227  =item options  =item multiple
1228    
1229  Reference to a hash containing the options to be applied to the C<SELECT> tag form the menu.  TRUE if the user is allowed to select multiple genomes, else FALSE.
 Typical options would include C<multiple> to specify  
 that multiple selections are allowed and C<size> to set the number of rows to display  
 in the menu.  
1230    
1231  =item selected  =item selected
1232    
# Line 913  Line 1234 
1234  is not intended to allow multiple selections, the list should be a singleton. If the  is not intended to allow multiple selections, the list should be a singleton. If the
1235  list is empty, nothing will be pre-selected.  list is empty, nothing will be pre-selected.
1236    
1237    =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    =item crossMenu (optional)
1243    
1244    This is currently not supported.
1245    
1246  =item RETURN  =item RETURN
1247    
1248  Returns the HTML text to generate a C<SELECT> menu inside a form.  Returns the HTML text to generate a C<SELECT> menu inside a form.
# Line 923  Line 1253 
1253    
1254  sub NmpdrGenomeMenu {  sub NmpdrGenomeMenu {
1255      # Get the parameters.      # Get the parameters.
1256      my ($self, $menuName, $options, $selected) = @_;      my ($self, $menuName, $multiple, $selected, $rows, $cross) = @_;
1257      # Get the Sprout and CGI objects.      # Get the Sprout and CGI objects.
1258      my $sprout = $self->DB();      my $sprout = $self->DB();
1259      my $cgi = $self->Q();      my $cgi = $self->Q();
1260      # Get the form name.      # Compute the row count.
1261      my $formName = $self->FormName();      if (! defined $rows) {
1262      # Get a list of all the genomes in group order. In fact, we only need them ordered          $rows = ($multiple ? 10 : 1);
1263      # by name (genus,species,strain), but putting primary-group in front enables us to      }
1264      # take advantage of an existing index.      # Get a comma-delimited list of the preselected genomes.
1265      my @genomeList = $sprout->GetAll(['Genome'],      my $preselected = "";
1266                                     "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",      if ($selected) {
1267                                     [], ['Genome(primary-group)', 'Genome(id)',          $preselected = join(", ", @$selected);
1268                                          'Genome(genus)', 'Genome(species)',      }
1269                                          'Genome(unique-characterization)']);      # Ask Sprout for a genome menu.
1270      # Create a hash to organize the genomes by group. Each group will contain a list of      my $retVal = $sprout->GenomeMenu(name => $menuName,
1271      # 2-tuples, the first element being the genome ID and the second being the genome                                       multiSelect => $multiple,
1272      # name.                                       selected => $preselected,
1273      my %groupHash = ();                                       size => $rows);
     for my $genome (@genomeList) {  
         # Get the genome data.  
         my ($group, $genomeID, $genus, $species, $strain) = @{$genome};  
         # Form the genome name.  
         my $name = "$genus $species";  
         if ($strain) {  
             $name .= " $strain";  
         }  
         # Push the genome into the group's list.  
         push @{$groupHash{$group}}, [$genomeID, $name];  
     }  
     # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting  
     # the supporting-genome group last.  
     my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %groupHash;  
     push @groups, $FIG_Config::otherGroup;  
     # Next, create a hash that specifies the pre-selected entries.  
     my %selectedHash = map { $_ => 1 } @{$selected};  
     # Now it gets complicated. We need a way to mark all the NMPDR genomes.  
     # Create the type counters.  
     my $groupCount = 1;  
     # Compute the ID for the status display.  
     my $divID = "${formName}_${menuName}_status";  
     # Compute the JavaScript call for updating the status.  
     my $showSelect = "showSelected($menuName, '$divID', 1000);";  
     # If multiple selection is supported, create an onChange event.  
     my $onChange = "";  
     if ($options->{multiple}) {  
         $onChange = " onChange=\"$showSelect\"";  
     }  
     # Create the SELECT tag and stuff it into the output array.  
     my $select = "<" . join(" ", "SELECT name=\"$menuName\"$onChange", map { " $_=\"$options->{$_}\"" } keys %{$options}) . ">";  
     my @lines = ($select);  
     # Loop through the groups.  
     for my $group (@groups) {  
         # Create the option group tag.  
         my $tag = "<OPTGROUP label=\"$group\">";  
         push @lines, "  $tag";  
         # Compute the label for this group's options. This is seriously dirty stuff, as the  
         # label option may have functionality in future browsers. If that happens, we'll need  
         # to modify the genome text so that the "selectSome" method can tell which are NMPDR  
         # organisms and which aren't. Sadly, the OPTGROUP tag is invisible in the DOM Javascript  
         # hierarchy.  
         my $label = ($group eq $FIG_Config::otherGroup ? "other" : "nmpdr");  
         # Get the genomes in the group.  
         for my $genome (@{$groupHash{$group}}) {  
             my ($genomeID, $name) = @{$genome};  
             # See if it's selected.  
             my $select = ($selectedHash{$genomeID} ? " selected" : "");  
             # Generate the option tag.  
             my $optionTag = "<OPTION value=\"$genomeID\" label=\"$label\"$select>$name <em>($genomeID)</em></OPTION>";  
             push @lines, "    $optionTag";  
         }  
         # Close the option group.  
         push @lines, "  </OPTGROUP>";  
     }  
     # Close the SELECT tag.  
     push @lines, "</SELECT>";  
     # Check for multiple selection.  
     if ($options->{multiple}) {  
         # Since multi-select is on, we can set up some buttons to set and clear selections.  
         push @lines, "<br />";  
         push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";  
         push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";  
         push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\"  value=\"Select NMPDR\" onClick=\"selectSome($menuName, 'nmpdr'); $showSelect\" />";  
         push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, 'other'); $showSelect\" />";  
         # Add the status display, too.  
         push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";  
         # Queue to update the status display when the form loads. We need to modify the show statement  
         # slightly because the queued statements are executed outside the form. This may seem like a lot of  
         # trouble, but we want all of the show statement calls to be generated from a single line of code,  
         # in case we decide to twiddle the parameters.  
         $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;  
         $self->QueueFormScript($showSelect);  
     }  
     # Assemble all the lines into a string.  
     my $retVal = join("\n", @lines, "");  
1274      # Return the result.      # Return the result.
1275      return $retVal;      return $retVal;
1276  }  }
1277    
1278  =head3 MakeTable  =head3 MakeTable
1279    
1280  C<< my $htmlText = $shelp->MakeTable(\@rows); >>      my $htmlText = $shelp->MakeTable(\@rows);
1281    
1282  Create a table from a group of table rows. The table rows must be fully pre-formatted: in  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.  other words, each must have the TR and TD tags included.
# Line 1039  Line 1293 
1293  =item rows  =item rows
1294    
1295  Reference to a list of table rows. Each table row must be in HTML form with all  Reference to a list of table rows. Each table row must be in HTML form with all
1296  the TR and TD tags set up. The first TD or TH tag in each row will be modified to  the TR and TD tags set up. The first TD or TH tag in the first non-colspanned row
1297  set the width. Everything else will be left as is.  will be modified to set the width. Everything else will be left as is.
1298    
1299  =item RETURN  =item RETURN
1300    
# Line 1055  Line 1309 
1309      my ($self, $rows) = @_;      my ($self, $rows) = @_;
1310      # Get the CGI object.      # Get the CGI object.
1311      my $cgi = $self->Q();      my $cgi = $self->Q();
1312      # Fix the widths on the first column. Note that we eschew the use of the "g"      # 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      # modifier becase we only want to change the first tag. Also, if a width      # 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.      # is already specified on the first column bad things will happen.
1317      for my $row (@{$rows}) {      for my $row (@{$rows}) {
1318          $row =~ s/(<td|th)/$1 width="150"/i;          # 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      }      }
1333      # Create the table.      # Create the table.
1334      my $retVal = $cgi->table({border => 2, cellspacing => 2,      my $retVal = CGI::table({border => 2, cellspacing => 2,
1335                                width => 700, class => 'search'},                                width => 700, class => 'search'},
1336                               @{$rows});                               @{$rows});
1337      # Return the result.      # Return the result.
# Line 1071  Line 1340 
1340    
1341  =head3 SubmitRow  =head3 SubmitRow
1342    
1343  C<< my $htmlText = $shelp->SubmitRow(); >>      my $htmlText = $shelp->SubmitRow($caption);
1344    
1345  Returns the HTML text for the row containing the page size control  Returns the HTML text for the row containing the page size control
1346  and the submit button. All searches should have this row somewhere  and the submit button. All searches should have this row somewhere
1347  near the top of the form.  near the top of the form.
1348    
1349    =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  =cut  =cut
1363    
1364  sub SubmitRow {  sub SubmitRow {
1365      # Get the parameters.      # Get the parameters.
1366      my ($self) = @_;      my ($self, $caption) = @_;
1367      my $cgi = $self->Q();      my $cgi = $self->Q();
1368      # Declare the return variable.      # Compute the button caption.
1369      my $retVal = $cgi->Tr($cgi->td("Results/Page"),      my $realCaption = (defined $caption ? $caption : 'Go');
1370                            $cgi->td($cgi->popup_menu(-name => 'PageSize',      # Get the current page size.
1371                                                      -values => [10, 25, 45, 100, 1000],      my $pageSize = $cgi->param('PageSize');
1372                                                      -default => $cgi->param('PageSize'))),      # Get the form name.
1373                            $cgi->td($cgi->submit(-class => 'goButton',      my $formName = $self->FormName();
1374        # Get the current feature ID type.
1375        my $aliasType = $self->GetPreferredAliasType();
1376        # Create the rows.
1377        my $retVal = CGI::Tr(CGI::td("Identifier Type "),
1378                              CGI::td({ colspan => 2 },
1379                                       CGI::popup_menu(-name => 'AliasType',
1380                                                        -values => ['FIG', AliasAnalysis::AliasTypes() ],
1381                                                        -default => $aliasType) .
1382                                       Hint("Identifier Type", 27))) .
1383                     "\n" .
1384                     CGI::Tr(CGI::td("Results/Page"),
1385                              CGI::td(CGI::popup_menu(-name => 'PageSize',
1386                                                      -values => [50, 10, 25, 100, 1000],
1387                                                      -default => $pageSize)),
1388                              CGI::td(CGI::submit(-class => 'goButton',
1389                                                  -name => 'Search',                                                  -name => 'Search',
1390                                                  -value => 'Go')));                                                  -value => $realCaption)));
1391      # Return the result.      # Return the result.
1392      return $retVal;      return $retVal;
1393  }  }
 =head3 GBrowseFeatureURL  
1394    
1395  C<< my $url = SearchHelper::GBrowseFeatureURL($sprout, $feat); >>  =head3 GetGenomes
1396    
1397  Compute the URL required to pull up a Gbrowse page for the the specified feature.      my @genomeList = $shelp->GetGenomes($parmName);
1398  In order to do this, we need to pull out the ID of the feature's Genome, its  
1399  contig ID, and some rough starting and stopping offsets.  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  =over 4
1406    
1407  =item sprout  =item parmName
1408    
1409  Sprout object for accessing the database.  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        my $url = $shelp->ComputeSearchURL(%overrides);
1442    
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    =over 4
1452    
1453  =item feat  =item overrides
1454    
1455  ID of the feature whose Gbrowse URL is desired.  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  =item RETURN
1460    
1461  Returns a GET-style URL for the Gbrowse CGI, with parameters specifying the genome  Returns a GET-style URL for invoking the search with the specified overrides.
 ID, contig ID, starting offset, and stopping offset.  
1462    
1463  =back  =back
1464    
1465  =cut  =cut
1466    
1467  sub GBrowseFeatureURL {  sub ComputeSearchURL {
1468      # Get the parameters.      # Get the parameters.
1469      my ($sprout, $feat) = @_;      my ($self, %overrides) = @_;
1470      # Declare the return variable.      # Get the database and CGI query object.
1471      my $retVal;      my $cgi = $self->Q();
1472      # Compute the genome ID.      my $sprout = $self->DB();
1473      my ($genomeID) = FIGRules::ParseFeatureID($feat);      # Start with the full URL.
1474      # Only proceed if the feature ID produces a valid genome.      my $retVal = "$FIG_Config::cgi_url/SearchSkeleton.cgi";
1475      if ($genomeID) {      # Get all the query parameters in a hash.
1476          # Get the feature location string.      my %parms = $cgi->Vars();
1477          my $loc = $sprout->FeatureLocation($feat);      # Now we need to do some fixing. Each multi-valued parameter is encoded as a string with null
1478          # Compute the contig, start, and stop points.      # characters separating the individual values. We have to convert those to lists. In addition,
1479          my($start, $stop, $contig) = BasicLocation::Parse($loc);      # the multiple-selection genome parameters and the feature type parameter must be checked to
1480          # Now we need to do some goofiness to insure that the location is not too      # determine whether or not they can be removed from the URL. First, we get a list of the
1481          # big and that we get some surrounding stuff.      # genome parameters and a list of all genomes. Note that we only need the list if a
1482          my $mid = int(($start + $stop) / 2);      # multiple-selection genome parameter has been found on the form.
1483          my $chunk_len = 20000;      my %genomeParms = map { $_ => 1 } @{$self->{genomeParms}};
1484          my $max_feature = 40000;      my @genomeList;
1485          my $feat_len = abs($stop - $start);      if (keys %genomeParms) {
1486          if ($feat_len > $chunk_len) {          @genomeList = $sprout->Genomes();
1487              if ($feat_len > $max_feature) {      }
1488                  $chunk_len = $max_feature;      # 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            if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) {
1497                # 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            } elsif (exists $overrides{$parmKey}) {
1511                # Here the value is being overridden, so we skip it for now.
1512                @values = ();
1513            }
1514            # If we still have values, create the URL parameters.
1515            if (@values) {
1516                push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1517            }
1518        }
1519        # 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        # Add the parameters to the URL.
1527        $retVal .= "?" . join(";", @urlList);
1528        # Return the result.
1529        return $retVal;
1530    }
1531    
1532    =head3 AdvancedClassList
1533    
1534        my @classes = SearchHelper::AdvancedClassList();
1535    
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    We do a file search to accomplish this, but to pull it off we need to look at %INC.
1540    
1541    =cut
1542    
1543    sub AdvancedClassList {
1544        # 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        return sort @retVal;
1553    }
1554    
1555    =head3 SelectionTree
1556    
1557        my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options);
1558    
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                                Campylobacteraceae =>
1623                                    {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    on the image will expand a section of the tree. The default is C<plus.gif>.
1667    
1668    =item nodeImageOpen
1669    
1670    URL of the image to display next to the tree nodes when they are expanded. Clicking
1671    on the image will collapse a section of the tree. The default is C<minus.gif>.
1672    
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           margin-left: 0; padding-left: 22px
1681        }
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                                               nodeImageClosed => "$FIG_Config::cgi_url/Html/plus.gif",
1712                                               nodeImageOpen => "$FIG_Config::cgi_url/Html/minus.gif",
1713                                               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 {              } else {
1730                  $chunk_len = $feat_len + 100;              # Here we have a real tree. Apply the tree style.
1731                push @retVal, CGI::start_div({ class => $optionThing->{style} });
1732                # 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                push @retVal, CGI::end_div();
1738            }
1739              }              }
1740        # Return the result.
1741        return join("\n", @retVal, "");
1742    }
1743    
1744    =head3 ShowBranch
1745    
1746        my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType);
1747    
1748    This is a recursive method that displays a branch of the tree.
1749    
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        push @retVal, CGI::start_ul({ id => $id, style => "display:$displayType" });
1796        # 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          }          }
         my($show_start, $show_stop);  
         if ($chunk_len == $max_feature) {  
             $show_start = $start - 300;  
1835          } else {          } else {
1836              $show_start = $mid - int($chunk_len / 2);                          $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                            push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'block');
1842                            Trace("Children of $myLabel finished.") if T(4);
1843                        }
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                my $prefixHtml = CGI::img({src => $image, id => "${myID}img"});
1854                if ($hasChildren) {
1855                    # If there are children, we wrap the image in a toggle hyperlink.
1856                    $prefixHtml = CGI::a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" },
1857                                          $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                    $prefixHtml .= CGI::input($radioParms);
1874                }
1875                # Next, we format the label.
1876                my $labelHtml = $myLabel;
1877                Trace("Formatting tree node for \"$myLabel\".") if T(4);
1878                # Apply a hyperlink if necessary.
1879                if (defined $attrHash->{link}) {
1880                    $labelHtml = CGI::a({ href => $attrHash->{link}, target => $options->{target} },
1881                                         $labelHtml);
1882          }          }
1883          if ($show_start < 1) {              # Finally, roll up the child HTML. If there are no children, we'll get a null string
1884              $show_start = 1;              # here.
1885                my $childHtml = join("\n", @childHtml);
1886                # Now we have all the pieces, so we can put them together.
1887                push @retVal, CGI::li("$prefixHtml$labelHtml$childHtml");
1888          }          }
         $show_stop = $show_start + $chunk_len - 1;  
         my $clen = $sprout->ContigLength($contig);  
         if ($show_stop > $clen) {  
             $show_stop = $clen;  
         }  
         my $seg_id = $contig;  
         $seg_id =~ s/:/--/g;  
         # Assemble all the pieces.  
         $retVal = "gbrowse.cgi/GB_$genomeID?ref=$seg_id&start=$show_start&stop=$show_stop";  
1889      }      }
1890        # Close the tree branch.
1891        push @retVal, CGI::end_ul();
1892      # Return the result.      # Return the result.
1893      return $retVal;      return @retVal;
1894  }  }
1895    
1896  =head2 Feature Column Methods  =head3 GetDivID
1897    
1898        my $idString = SearchHelper::GetDivID($name);
1899    
1900    Return a new HTML ID string.
1901    
1902  The methods in this column manage feature column data. If you want to provide the  =over 4
 capability to include new types of data in feature columns, then all the changes  
 are made to this section of the source file. Technically, this should be implemented  
 using object-oriented methods, but this is simpler for non-programmers to maintain.  
 To add a new column of feature data, you must first give it a name. For example,  
 the name for the protein page link column is C<protlink>. If the column is to appear  
 in the default list of feature columns, add it to the list returned by  
 L</DefaultFeatureColumns>. Then add code to produce the column title to  
 L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>, and  
 everything else will happen automatically.  
1903    
1904  There is one special column name syntax for extra columns (that is, nonstandard  =item name
 feature columns). If the column name begins with C<X=>, then it is presumed to be  
 an extra column. The column title is the text after the C<X=>, and its value is  
 pulled from the extra column hash.  
1905    
1906  =head3 DefaultFeatureColumns  Name to be prefixed to the ID string.
1907    
1908  C<< my $colNames = $shelp->DefaultFeatureColumns(); >>  =item RETURN
1909    
1910  Return a reference to a list of the default feature column identifiers. These  Returns a hopefully-unique ID string.
1911  identifiers can be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in  
1912  order to produce the column titles and row values.  =back
1913    
1914  =cut  =cut
1915    
1916  sub DefaultFeatureColumns {  sub GetDivID {
1917      # Get the parameters.      # Get the parameters.
1918      my ($self) = @_;      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.      # Return the result.
1924      return ['orgName', 'function', 'gblink', 'protlink'];      return $retVal;
1925  }  }
1926    
1927  =head3 FeatureColumnTitle  =head3 PrintLine
1928    
1929  C<< my $title = $shelp->FeatureColumnTitle($colName); >>      $shelp->PrintLine($message);
1930    
1931  Return the column heading title to be used for the specified feature column.  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  =over 4
1935    
1936  =item name  =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        # Send the message to the output.
1948        print "$message\n";
1949    }
1950    
1951    =head3 GetHelper
1952    
1953        my $shelp = SearchHelper::GetHelper($parm, $type => $className);
1954    
1955  Name of the desired feature column.  Return a helper object with the given class name. If no such class exists, an
1956    error will be thrown.
1957    
1958    =over 4
1959    
1960    =item parm
1961    
1962    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    
1965    =item type
1966    
1967    Type of helper: C<RH> for a result helper and C<SH> for a search helper.
1968    
1969    =item className
1970    
1971    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    
1974  =item RETURN  =item RETURN
1975    
1976  Returns the title to be used as the column header for the named feature column.  Returns a helper object for the specified class.
1977    
1978  =back  =back
1979    
1980  =cut  =cut
1981    
1982  sub FeatureColumnTitle {  sub GetHelper {
1983      # Get the parameters.      # Get the parameters.
1984      my ($self, $colName) = @_;      my ($parm, $type, $className) = @_;
1985      # Declare the return variable. We default to a blank column name.      # Declare the return variable.
1986      my $retVal = "&nbsp;";      my $retVal;
1987      # Process the column name.      # Try to create the helper.
1988      if ($colName =~ /^X=(.+)$/) {      eval {
1989          # Here we have an extra column.          # Load it into memory. If it's already there nothing will happen here.
1990          $retVal = $1;          my $realName = "$type$className";
1991      } elsif ($colName eq 'orgName') {          Trace("Requiring helper $realName.") if T(3);
1992          $retVal = "Name";          require "$realName.pm";
1993      } elsif ($colName eq 'fid') {          Trace("Constructing helper object.") if T(3);
1994          $retVal = "FIG ID";          # Construct the object.
1995      } elsif ($colName eq 'alias') {          $retVal = eval("$realName->new(\$parm)");
1996          $retVal = "External Aliases";          # Commit suicide if it didn't work.
1997      } elsif ($colName eq 'function') {          if (! defined $retVal) {
1998          $retVal = "Functional Assignment";              die "Could not find a $type handler of type $className.";
1999      } elsif ($colName eq 'gblink') {          } else {
2000          $retVal = "GBrowse";              # Perform any necessary subclass initialization.
2001      } elsif ($colName eq 'protlink') {              $retVal->Initialize();
2002          $retVal = "NMPDR Protein Page";          }
2003      } elsif ($colName eq 'group') {      };
2004          $retVal = "NMDPR Group";      # Check for errors.
2005        if ($@) {
2006            Confess("Error retrieving $type$className: $@");
2007      }      }
2008      # Return the result.      # Return the result.
2009      return $retVal;      return $retVal;
2010  }  }
2011    
2012  =head3 FeatureColumnValue  =head3 SaveOrganismData
2013    
2014        my ($name, $displayGroup, $domain) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain, $taxonomy);
2015    
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    =item taxonomy
2045    
2046    Taxonomy of the species represented by the genome.
2047    
2048    =item RETURN
2049    
2050    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    
2053    =back
2054    
2055    =cut
2056    
2057    sub SaveOrganismData {
2058        # Get the parameters.
2059        my ($self, $group, $genomeID, $genus, $species, $strain, $taxonomy) = @_;
2060        # 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            Trace("Group = $displayGroup, translated from \"$group\".") if T(4);
2076        }
2077        # Compute the domain from the taxonomy.
2078        my ($domain) = split /\s*;\s*/, $taxonomy, 2;
2079        # Cache the group and organism data.
2080        my $cache = $self->{orgs};
2081        $cache->{$genomeID} = [$name, $displayGroup, $domain];
2082        # Return the result.
2083        return ($name, $displayGroup, $domain);
2084    }
2085    
2086    =head3 ValidateKeywords
2087    
2088  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>      my $okFlag = $shelp->ValidateKeywords($keywordString, $required);
2089    
2090  Return the value to be displayed in the specified feature column.  Insure that a keyword string is reasonably valid. If it is invalid, a message will be
2091    set.
2092    
2093  =over 4  =over 4
2094    
2095  =item colName  =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            } else {
2125                $retVal = 1;
2126            }
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    =head3 TuningParameters
2137    
2138  Name of the column to be displayed.      my $options = $shelp->TuningParameters(%parmHash);
2139    
2140  =item record  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  DBObject record for the feature being displayed in the current row.  =over 4
2144    
2145  =item extraCols  =item parmHash
2146    
2147  Reference to a hash of extra column names to values. If the incoming column name  Hash mapping parameter names to their default values.
 begins with C<X=>, its value will be taken from this hash.  
2148    
2149  =item RETURN  =item RETURN
2150    
2151  Returns the HTML to be displayed in the named column for the specified feature.  Returns a reference to a hash containing the parameter names mapped to their actual values.
2152    
2153  =back  =back
2154    
2155  =cut  =cut
2156    
2157  sub FeatureColumnValue {  sub TuningParameters {
2158      # Get the parameters.      # Get the parameters.
2159      my ($self, $colName, $record, $extraCols) = @_;      my ($self, %parmHash) = @_;
2160      # Get the sprout and CGI objects.      # Declare the return variable.
2161        my $retVal = {};
2162        # Get the CGI Query Object.
2163      my $cgi = $self->Q();      my $cgi = $self->Q();
2164      my $sprout = $self->DB();      # Loop through the parameter names.
2165      # Get the feature ID.      for my $parm (keys %parmHash) {
2166      my ($fid) = $record->Value('Feature(id)');          # Get the incoming value for this parameter.
2167      # Declare the return variable. Denote that we default to a non-breaking space,          my $value = $cgi->param($parm);
2168      # which will translate to an empty table cell (rather than a table cell with no          # Zero might be a valid value, so we do an is-defined check rather than an OR.
2169      # interior, which is what you get for a null string).          if (defined($value)) {
2170      my $retVal = "&nbsp;";              $retVal->{$parm} = $value;
2171      # Process according to the column name.          } else {
2172      if ($colName =~ /^X=(.+)$/) {              $retVal->{$parm} = $parmHash{$parm};
2173          # Here we have an extra column. Only update if the value exists. Note that          }
         # a value of C<undef> is treated as a non-existent value, because the  
         # caller may have put "colName => undef" in the "PutFeature" call in order  
         # to insure we know the extra column exists.  
         if (defined $extraCols->{$1}) {  
             $retVal = $extraCols->{$1};  
         }  
     } elsif ($colName eq 'orgName') {  
         # Here we want the formatted organism name and feature number.  
         $retVal = $self->FeatureName($fid);  
     } elsif ($colName eq 'fid') {  
         # Here we have the raw feature ID. We hyperlink it to the protein page.  
         $retVal = HTML::set_prot_links($fid);  
     } elsif ($colName eq 'alias') {  
         # In this case, the user wants a list of external aliases for the feature.  
         # The complicated part is we have to hyperlink them. First, get the  
         # aliases.  
         my @aliases = $sprout->FeatureAliases($fid);  
         # Only proceed if we found some.  
         if (@aliases) {  
             # Join the aliases into a comma-delimited list.  
             my $aliasList = join(", ", @aliases);  
             # Ask the HTML processor to hyperlink them.  
             $retVal = HTML::set_prot_links($aliasList);  
         }  
     } elsif ($colName eq 'function') {  
         # The functional assignment is just a matter of getting some text.  
         ($retVal) = $record->Value('Feature(assignment)');  
     } elsif ($colName eq 'gblink') {  
         # Here we want a link to the GBrowse page using the official GBrowse button.  
         my $gurl = "GetGBrowse.cgi?fid=$fid";  
         $retVal = $cgi->a({ href => $gurl, title => "GBrowse for $fid" },  
                           $cgi->img({ src => "../images/button-gbrowse.png",  
                                       border => 0 })  
                          );  
     } elsif ($colName eq 'protlink') {  
         # Here we want a link to the protein page using the official NMPDR button.  
         my $hurl = HTML::fid_link($cgi, $fid, 0, 1);  
         $retVal = $cgi->a({ href => $hurl, title => "Protein page for $fid" },  
                           $cgi->img({ src => "../images/button-nmpdr.png",  
                                      border => 0 })  
                          );  
     } elsif ($colName eq 'group') {  
         # Get the NMPDR group name.  
         my (undef, $group) = $self->OrganismData($fid);  
         # Dress it with a URL to the group's main page.  
         my $nurl = $sprout->GroupPageName($group);  
         $retVal = $cgi->a({ href => $nurl, title => "$group summary" },  
                           $group);  
2174      }      }
2175      # Return the result.      # Return the result.
2176      return $retVal;      return $retVal;
2177  }  }
2178    
2179    =head3 GetPreferredAliasType
2180    
2181        my $type = $shelp->GetPreferredAliasType();
2182    
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    =head3 Hint
2200    
2201        my $htmlText = SearchHelper::Hint($wikiPage, $hintID);
2202    
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    =item hintID
2213    
2214    ID of the text to display for the hint. This is the ID number for a tip-of-the-day.
2215    
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        my ($wikiPage, $hintID) = @_;
2228        # Ask Sprout to draw the hint button for us.
2229        return Sprout::Hint($wikiPage, $hintID);
2230    }
2231    
2232    
2233    
2234    =head2 Virtual Methods
2235    
2236    =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    =head3 Form
2250    
2251        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    
2257    =cut
2258    
2259    sub Form {
2260        # Get the parameters.
2261        my ($self) = @_;
2262        return "";
2263    }
2264    
2265    =head3 Find
2266    
2267        my $resultCount = $shelp->Find();
2268    
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    =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    =head3 Description
2284    
2285        my $htmlText = $shelp->Description();
2286    
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    sub Description {
2294        # Get the parameters.
2295        my ($self) = @_;
2296        $self->Message("Call to pure virtual Description method in helper of type " . ref($self) . ".");
2297        return "Unknown search type";
2298    }
2299    
2300    =head3 SearchTitle
2301    
2302        my $titleHtml = $shelp->SearchTitle();
2303    
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        my $retVal = "";
2315        # Return it.
2316        return $retVal;
2317    }
2318    
2319    =head3 DefaultColumns
2320    
2321        $shelp->DefaultColumns($rhelp);
2322    
2323    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    
2327    =over 4
2328    
2329    =item rhelp
2330    
2331    Result helper object in which the column list should be stored.
2332    
2333    =back
2334    
2335    =cut
2336    
2337    sub DefaultColumns {
2338        # Get the parameters.
2339        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    }
2345    
2346    
2347    =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    
2359    =head3 GetResultHelper
2360    
2361        my $rhelp = $shelp->GetResultHelper($className);
2362    
2363    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    
2368    =over 4
2369    
2370    =item className
2371    
2372    Result helper class name.
2373    
2374    =item RETURN
2375    
2376    Returns a result helper of the specified class connected to this search helper.
2377    
2378    =back
2379    
2380    =cut
2381    
2382    sub GetResultHelper {
2383        # Get the parameters.
2384        my ($self, $className) = @_;
2385        # Create the helper.
2386        my $retVal = GetHelper($self, RH => $className);
2387        # return it.
2388        return $retVal;
2389    }
2390    
2391  1;  1;

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.47

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3