[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.29, Sat Apr 14 21:41:25 2007 UTC
# Line 16  Line 16 
16      use FIGRules;      use FIGRules;
17      use HTML;      use HTML;
18      use BasicLocation;      use BasicLocation;
19        use FeatureQuery;
20        use URI::Escape;
21        use PageBuilder;
22    
23  =head1 Search Helper Base Class  =head1 Search Helper Base Class
24    
# Line 72  Line 75 
75    
76  List of JavaScript statements to be executed after the form is closed.  List of JavaScript statements to be executed after the form is closed.
77    
78    =item genomeHash
79    
80    Cache of the genome group hash used to build genome selection controls.
81    
82    =item genomeParms
83    
84    List of the parameters that are used to select multiple genomes.
85    
86    =item filtered
87    
88    TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this
89    field is updated by the B<FeatureQuery> object.
90    
91    =item extraPos
92    
93    C<0> if the extra columns are to be at the beginning, else C<1>. The
94    default is zero; use the L</SetExtraPos> method to change this option.
95    
96    =back
97    
98    =head2 Adding a new Search Tool
99    
100    To add a new search tool to the system, you must
101    
102    =over 4
103    
104    =item 1
105    
106    Choose a class name for your search tool.
107    
108    =item 2
109    
110    Create a new subclass of this object and implement each of the virtual methods. The
111    name of the subclass must be C<SH>I<className>.
112    
113    =item 3
114    
115    Create an include file among the web server pages that describes how to use
116    the search tool. The include file must be in the B<includes> directory, and
117    its name must be C<SearchHelp_>I<className>C<.inc>.
118    
119    =item 4
120    
121    In the C<SearchSkeleton.cgi> script and add a C<use> statement for your search tool.
122    
123    =back
124    
125    =head3 Building a Search Form
126    
127    All search forms are three-column tables. In general, you want one form
128    variable per table row. The first column should contain the label and
129    the second should contain the form control for specifying the variable
130    value. If the control is wide, you should use C<colspan="2"> to give it
131    extra room. B<Do not> specify a width in any of your table cells, as
132    width management is handled by this class.
133    
134    The general code for creating the form should be
135    
136        sub Form {
137            my ($self) = @_;
138            # Get the CGI object.
139            my $cgi = @self->Q();
140            # Start the form.
141            my $retVal = $self->FormStart("form title");
142            # Assemble the table rows.
143            my @rows = ();
144            ... push table row Html into @rows ...
145            push @rows, $self->SubmitRow();
146            ... push more Html into @rows ...
147            # Build the table from the rows.
148            $retVal .= $self->MakeTable(\@rows);
149            # Close the form.
150            $retVal .= $self->FormEnd();
151            # Return the form Html.
152            return $retVal;
153        }
154    
155    Several helper methods are provided for particular purposes.
156    
157    =over 4
158    
159    =item 1
160    
161    L</NmpdrGenomeMenu> generates a control for selecting one or more genomes. Use
162    L</GetGenomes> to retrieve all the genomes passed in for a specified parameter
163    name. Note that as an assist to people working with GET-style links, if no
164    genomes are specified and the incoming request style is GET, all genomes will
165    be returned.
166    
167    =item 2
168    
169    L</FeatureFilterRow> formats several rows of controls for filtering features.
170    When you start building the code for the L</Find> method, you can use a
171    B<FeatureQuery> object to automatically filter each genome's features using
172    the values from the filter controls.
173    
174    =item 3
175    
176    L</QueueFormScript> allows you to queue JavaScript statements for execution
177    after the form is fully generated. If you are using very complicated
178    form controls, the L</QueueFormScript> method allows you to perform
179    JavaScript initialization. The L</NmpdrGenomeMenu> control uses this
180    facility to display a list of the pre-selected genomes.
181    
182  =back  =back
183    
184    If you are doing a feature search, you can also change the list of feature
185    columns displayed and their display order by overriding
186    L</DefaultFeatureColumns>.
187    
188    Finally, when generating the code for your controls, be sure to use any incoming
189    query parameters as default values so that the search request is persistent.
190    
191    =head3 Finding Search Results
192    
193    The L</Find> method is used to create the search results. For a search that
194    wants to return features (which is most of them), the basic code structure
195    would work as follows. It is assumed that the L</FeatureFilterRows> method
196    has been used to create feature filtering parameters.
197    
198        sub Find {
199            my ($self) = @_;
200            # Get the CGI and Sprout objects.
201            my $cgi = $self->Q();
202            my $sprout = $self->DB();
203            # Declare the return variable. If it remains undefined, the caller will
204            # know that an error occurred.
205            my $retVal;
206            ... validate the parameters ...
207            if (... invalid parameters...) {
208                $self->SetMessage(...appropriate message...);
209            } elsif (FeatureQuery::Valid($self)) {
210                # Initialize the session file.
211                $self->OpenSession();
212                # Initialize the result counter.
213                $retVal = 0;
214                ... get a list of genomes ...
215                for my $genomeID (... each genome ...) {
216                    my $fq = FeatureQuery->new($self, $genomeID);
217                    while (my $feature = $fq->Fetch()) {
218                        ... examine the feature ...
219                        if (... we want to keep it ...) {
220                            $self->PutFeature($fq);
221                            $retVal++;
222                        }
223                    }
224                }
225                # Close the session file.
226                $self->CloseSession();
227            }
228            # Return the result count.
229            return $retVal;
230        }
231    
232    A Find method is of course much more complicated than generating a form, and there
233    are variations on the above theme. For example, you could eschew feature filtering
234    entirely in favor of your own custom filtering, you could include extra columns
235    in the output, or you could search for something that's not a feature at all. The
236    above code is just a loose framework.
237    
238    In addition to the finding and filtering, it is necessary to send status messages
239    to the output so that the user does not get bored waiting for results. The L</PrintLine>
240    method performs this function. The single parameter should be text to be
241    output to the browser. In general, you'll invoke it as follows.
242    
243        $self->PrintLine("...my message text...<br />");
244    
245    The break tag is optional. When the Find method gets control, a paragraph will
246    have been started so that everything is XHTML-compliant.
247    
248    If you wish to add your own extra columns to the output, use the B<AddExtraColumns>
249    method of the feature query object.
250    
251        $fq->AddExtraColumns(score => $sc);
252    
253    The L</Find> method must return C<undef> if the search parameters are invalid. If this
254    is the case, then a message describing the problem should be passed to the framework
255    by calling L</SetMessage>. If the parameters are valid, then the method must return
256    the number of items found.
257    
258  =cut  =cut
259    
260  # 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.
261  my $formCount = 0;  my $formCount = 0;
262    # This counter is used to generate unique DIV IDs.
263    my $divCount = 0;
264    
265  =head2 Public Methods  =head2 Public Methods
266    
267  =head3 new  =head3 new
268    
269  C<< my $shelp = SearchHelper->new($query); >>  C<< my $shelp = SearchHelper->new($cgi); >>
270    
271  Construct a new SearchHelper object.  Construct a new SearchHelper object.
272    
273  =over 4  =over 4
274    
275  =item query  =item cgi
276    
277  The CGI query object for the current script.  The CGI query object for the current script.
278    
# Line 99  Line 282 
282    
283  sub new {  sub new {
284      # Get the parameters.      # Get the parameters.
285      my ($class, $query) = @_;      my ($class, $cgi) = @_;
286      # Check for a session ID.      # Check for a session ID.
287      my $session_id = $query->param("SessionID");      my $session_id = $cgi->param("SessionID");
288      my $type = "old";      my $type = "old";
289      if (! $session_id) {      if (! $session_id) {
290            Trace("No session ID found.") if T(3);
291          # 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
292          # store it in the query object.          # store it in the query object.
293          $session_id = NewSessionID();          $session_id = NewSessionID();
294          $type = "new";          $type = "new";
295          $query->param(-name => 'SessionID', -value => $session_id);          $cgi->param(-name => 'SessionID', -value => $session_id);
296        } else {
297            Trace("Session ID is $session_id.") if T(3);
298      }      }
299      # Compute the subclass name.      # Compute the subclass name.
300      $class =~ /SH(.+)$/;      my $subClass;
301      my $subClass = $1;      if ($class =~ /SH(.+)$/) {
302      # Create the Sprout object.          # Here we have a real search class.
303      my $sprout = SFXlate->new_sprout_only();          $subClass = $1;
304        } else {
305            # Here we have a bare class. The bare class cannot search, but it can
306            # process search results.
307            $subClass = 'SearchHelper';
308        }
309      # Insure everybody knows we're in Sprout mode.      # Insure everybody knows we're in Sprout mode.
310      $query->param(-name => 'SPROUT', -value => 1);      $cgi->param(-name => 'SPROUT', -value => 1);
311      # Generate the form name.      # Generate the form name.
312      my $formName = "$class$formCount";      my $formName = "$class$formCount";
313      $formCount++;      $formCount++;
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                      filtered => 0,
328                      extraPos => 0,
329                   };                   };
330      # Bless and return it.      # Bless and return it.
331      bless $retVal, $class;      bless $retVal, $class;
# Line 152  Line 347 
347      return $self->{query};      return $self->{query};
348  }  }
349    
350    
351    
352  =head3 DB  =head3 DB
353    
354  C<< my $sprout = $shelp->DB(); >>  C<< my $sprout = $shelp->DB(); >>
# Line 163  Line 360 
360  sub DB {  sub DB {
361      # Get the parameters.      # Get the parameters.
362      my ($self) = @_;      my ($self) = @_;
363        # Insure we have a database.
364        my $retVal = $self->{sprout};
365        if (! defined $retVal) {
366            $retVal = SFXlate->new_sprout_only();
367            $self->{sprout} = $retVal;
368        }
369      # Return the result.      # Return the result.
370      return $self->{sprout};      return $retVal;
371  }  }
372    
373  =head3 IsNew  =head3 IsNew
# Line 183  Line 386 
386      return ($self->{type} eq 'new');      return ($self->{type} eq 'new');
387  }  }
388    
389    =head3 SetExtraPos
390    
391    C<< $shelp->SetExtraPos($newValue); >>
392    
393    Indicate whether the extra columns should be in the front (C<0>) or end (C<1>) columns of the results.
394    
395    =over 4
396    
397    =item newValue
398    
399    C<1> if the extra columns should be displayed at the end, else C<0>.
400    
401    =back
402    
403    =cut
404    
405    sub SetExtraPos {
406        my ($self, $newValue) = @_;
407        $self->{extraPos} = $newValue;
408    }
409    
410  =head3 ID  =head3 ID
411    
412  C<< my $sessionID = $shelp->ID(); >>  C<< my $sessionID = $shelp->ID(); >>
# Line 277  Line 501 
501      my ($self, $title) = @_;      my ($self, $title) = @_;
502      # Get the CGI object.      # Get the CGI object.
503      my $cgi = $self->Q();      my $cgi = $self->Q();
504      # Start the form.      # Start the form. Note we use the override option on the Class value, in
505        # case the Advanced button was used.
506      my $retVal = "<div class=\"search\">\n" .      my $retVal = "<div class=\"search\">\n" .
507                   $cgi->start_form(-method => 'POST',                   $cgi->start_form(-method => 'POST',
508                                    -action => $cgi->url(-relative => 1),                                    -action => $cgi->url(-relative => 1),
509                                    -name => $self->FormName()) .                                    -name => $self->FormName()) .
510                   $cgi->hidden(-name => 'Class',                   $cgi->hidden(-name => 'Class',
511                                -value => $self->{class}) .                                -value => $self->{class},
512                                  -override => 1) .
513                   $cgi->hidden(-name => 'SPROUT',                   $cgi->hidden(-name => 'SPROUT',
514                                -value => 1) .                                -value => 1) .
515                   $cgi->h3($title);                   $cgi->h3($title);
# Line 437  Line 663 
663    
664  =head3 PutFeature  =head3 PutFeature
665    
666  C<< $shelp->PutFeature($record, %extraCols); >>  C<< $shelp->PutFeature($fdata); >>
667    
668  Store a feature in the result cache. This is the workhorse method for most  Store a feature in the result cache. This is the workhorse method for most
669  searches, since the primary data item in the database is features.  searches, since the primary data item in the database is features.
670    
671  For each feature, there are certain columns that are standard: the feature name, the  For each feature, there are certain columns that are standard: the feature name, the
672  GBrowse and protein page links, the functional assignment, and so forth. If additional  GBrowse and protein page links, the functional assignment, and so forth. If additional
673  columns are required by a particular search subclass, they should be included in the  columns are required by a particular search subclass, they should be stored in
674  parameters, in key-value form. For example, the following call adds columns for  the feature query object using the B<AddExtraColumns> method. For example, the following
675  essentiality and virulence.  code adds columns for essentiality and virulence.
676    
677      $shelp->PutFeature($record, essential => $essentialFlag, virulence => $vfactor);      $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
678        $shelp->PutFeature($fd);
679    
680  For correct results, all values should be specified for all extra columns in all calls to  For correct results, all values should be specified for all extra columns in all calls to
681  B<PutFeature>. (In particular, the column header names are computed on the first  B<PutFeature>. (In particular, the column header names are computed on the first
# Line 458  Line 685 
685      if (! $essentialFlag) {      if (! $essentialFlag) {
686          $essentialFlag = undef;          $essentialFlag = undef;
687      }      }
688      $shelp->PutFeature($record, essential => $essentialFlag, virulence = $vfactor);      $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
689        $shelp->PutFeature($fd);
690    
691  =over 4  =over 4
692    
693  =item record  =item fdata
   
 DBObject record for the feature.  
694    
695  =item extraCols  B<FeatureData> object containing the current feature data.
696    
697  =back  =back
698    
699  =cut  =cut
700    
701  sub PutFeature {  sub PutFeature {
702      # Get the parameters. Note that the extra columns are read in as a list      # Get the parameters.
703      # instead of a hash so that the column order is preserved.      my ($self, $fd) = @_;
704      my ($self, $record, @extraColList) = @_;      # Get the CGI query object.
705        my $cgi = $self->Q();
706        # Get the feature data.
707        my $record = $fd->Feature();
708        my $extraCols = $fd->ExtraCols();
709      # Check for a first-call situation.      # Check for a first-call situation.
710      if (! defined $self->{cols}) {      if (! defined $self->{cols}) {
711          # Here we need to set up the column information. Start with the defaults.          Trace("Setting up the columns.") if T(3);
712          $self->{cols} = $self->DefaultFeatureColumns();          # Tell the user what's happening.
713          # Append the extras. Note we proceed by twos because the columns are          $self->PrintLine("Creating output columns.<br />");
714          # specified in the form name => value.          # Here we need to set up the column information. First we accumulate the extras,
715          for (my $i = 0; $i <= $#extraColList; $i += 2) {          # sorted by column name.
716              push @{$self->{cols}}, "X=$extraColList[$i]";          my @xtraNames = ();
717          }          for my $col (sort keys %{$extraCols}) {
718          # Write out the column headers. This also prepares the cache file to receive              push @xtraNames, "X=$col";
719            }
720            # Set up the column name array.
721            my @colNames = ();
722            # If extras go at the beginning, put them in first.
723            if (! $self->{extraPos}) {
724                push @colNames, @xtraNames;
725            }
726            # Add the default columns.
727            push @colNames, $self->DefaultFeatureColumns();
728            # Add any additional columns requested by the feature filter.
729            push @colNames, FeatureQuery::AdditionalColumns($self);
730            # If extras go at the end, put them in here.
731            if ($self->{extraPos}) {
732                push @colNames, @xtraNames;
733            }
734            Trace("Full column list determined.") if T(3);
735            # Save the full list.
736            $self->{cols} = \@colNames;
737            # Write out the column names. This also prepares the cache file to receive
738          # output.          # output.
739          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});          Trace("Writing column headers.") if T(3);
740            $self->WriteColumnHeaders(@{$self->{cols}});
741            Trace("Column headers written.") if T(3);
742      }      }
743      # Get the feature ID.      # Get the feature ID.
744      my ($fid) = $record->Value('Feature(id)');      my $fid = $fd->FID();
745      # Now we process the columns themselves. First, convert the extra column list      # Loop through the column headers, producing the desired data. The first column
746      # to a hash.      # is the feature ID. The feature ID does not show up in the output: its purpose
747      my %extraCols = @extraColList;      # is to help the various output formatters.
748      # Loop through the column headers, producing the desired data.      my @output = ($fid);
     my @output = ();  
749      for my $colName (@{$self->{cols}}) {      for my $colName (@{$self->{cols}}) {
750          push @output, $self->FeatureColumnValue($colName, $record, \%extraCols);          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
751      }      }
752      # Compute the sort key. The sort key floats NMPDR organism features to the      # Compute the sort key. The sort key usually floats NMPDR organism features to the
753      # top of the return list.      # top of the return list.
754      my $group = $self->FeatureGroup($fid);      my $key = $self->SortKey($fd);
     my $key = ($group ? "A$group" : "ZZ");  
755      # Write the feature data.      # Write the feature data.
756      $self->WriteColumnData($key, @output);      $self->WriteColumnData($key, @output);
757  }  }
# Line 583  Line 832 
832      # Check for an open session file.      # Check for an open session file.
833      if (defined $self->{fileHandle}) {      if (defined $self->{fileHandle}) {
834          # We found one, so close it.          # We found one, so close it.
835            Trace("Closing session file.") if T(2);
836          close $self->{fileHandle};          close $self->{fileHandle};
837            # Tell the user.
838            my $cgi = $self->Q();
839            $self->PrintLine("Output formatting complete.<br />");
840      }      }
841  }  }
842    
# Line 600  Line 853 
853      my $retVal;      my $retVal;
854      # Get a digest encoder.      # Get a digest encoder.
855      my $md5 = Digest::MD5->new();      my $md5 = Digest::MD5->new();
856      # If we have a randomization file, use it to seed the digester.      # Add the PID, the IP, and the time stamp. Note that the time stamp is
857      if (open(R, "/dev/urandom")) {      # actually two numbers, and we get them both because we're in list
858          my $b;      # context.
859          read(R, $b, 1024);      $md5->add($$, $ENV{REMOTE_ADDR}, $ENV{REMOTE_PORT}, gettimeofday());
860          $md5->add($b);      # Hash up all this identifying data.
861      }      $retVal = $md5->hexdigest();
862      # Add the PID and the time stamp.      # Return the result.
     $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.  
863      return $retVal;      return $retVal;
864  }  }
865    
# Line 656  Line 903 
903                                                      ['Genome(genus)', 'Genome(species)',                                                      ['Genome(genus)', 'Genome(species)',
904                                                       'Genome(unique-characterization)',                                                       'Genome(unique-characterization)',
905                                                       'Genome(primary-group)']);                                                       'Genome(primary-group)']);
906          # Null out the supporting group.          # Format and cache the name and display group.
907          $group = "" if ($group eq $FIG_Config::otherGroup);          ($orgName, $group) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
908          # If the organism does not exist, format an unknown name.                                                              $strain);
         if (! defined($genus)) {  
             $orgName = "Unknown Genome $genomeID";  
         } else {  
             # 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];  
909      }      }
910      # Return the result.      # Return the result.
911      return ($orgName, $group);      return ($orgName, $group);
# Line 771  Line 1007 
1007      } else {      } else {
1008          # Here we can get its genome data.          # Here we can get its genome data.
1009          $retVal = $self->Organism($genomeID);          $retVal = $self->Organism($genomeID);
1010          # Append the type and number.          # Append the FIG ID.
1011          $retVal .= " [$type $num]";          $retVal .= " [$fid]";
1012      }      }
1013      # Return the result.      # Return the result.
1014      return $retVal;      return $retVal;
# Line 780  Line 1016 
1016    
1017  =head3 ComputeFASTA  =head3 ComputeFASTA
1018    
1019  C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >>  C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence); >>
1020    
1021  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.
 that it is possible to convert a DNA sequence into a protein sequence, but the reverse  
 is not possible.  
1022    
1023  =over 4  =over 4
1024    
 =item incomingType  
   
 C<dna> if this is a DNA sequence, C<prot> if this is a protein sequence.  
   
1025  =item desiredType  =item desiredType
1026    
1027  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.
 I<$incomingType> is C<prot> and this value is C<dna>, an error will be thrown.  
1028    
1029  =item sequence  =item sequence
1030    
# Line 817  Line 1046 
1046    
1047  sub ComputeFASTA {  sub ComputeFASTA {
1048      # Get the parameters.      # Get the parameters.
1049      my ($self, $incomingType, $desiredType, $sequence) = @_;      my ($self, $desiredType, $sequence) = @_;
1050      # Declare the return variable. If an error occurs, it will remain undefined.      # Declare the return variable. If an error occurs, it will remain undefined.
1051      my $retVal;      my $retVal;
1052        # This variable will be cleared if an error is detected.
1053        my $okFlag = 1;
1054      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
1055      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
1056      # Check for a feature specification.      Trace("FASTA desired type is $desiredType.") if T(4);
1057        # Check for a feature specification. The smoking gun for that is a vertical bar.
1058      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
1059          # 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 the Sprout object to process
1060          # it.          # it.
1061          my $fid = $1;          my $fid = $1;
1062            Trace("Feature ID for fasta is $fid.") if T(3);
1063          my $sprout = $self->DB();          my $sprout = $self->DB();
1064          # 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
1065          # 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
1066          # exist.          # exist.
1067          my ($figID) = $sprout->FeaturesByAlias($fid);          my ($figID) = $sprout->FeaturesByAlias($fid);
1068          if (! $figID) {          if (! $figID) {
1069              $self->SetMessage("No feature found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
1070                $okFlag = 0;
1071          } else {          } else {
1072              # Set the FASTA label.              # Set the FASTA label. The ID is the first favored alias.
1073              my $fastaLabel = $fid;              my $favored = $self->Q()->param('FavoredAlias') || 'fig';
1074                my $favorLen = length $favored;
1075                ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid);
1076                if (! $fastaLabel) {
1077                    # In an emergency, fall back to the original ID.
1078                    $fastaLabel = $fid;
1079                }
1080              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
1081              if ($desiredType =~ /prot/i) {              if ($desiredType eq 'prot') {
1082                  # We want protein, so get the translation.                  # We want protein, so get the translation.
1083                  $fastaData = $sprout->FeatureTranslation($figID);                  $fastaData = $sprout->FeatureTranslation($figID);
1084                    Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
1085              } else {              } else {
1086                  # We want DNA, so get the DNA sequence. This is a two-step process.                  # We want DNA, so get the DNA sequence. This is a two-step process.
1087                  my @locList = $sprout->FeatureLocation($figID);                  my @locList = $sprout->FeatureLocation($figID);
1088                  $fastaData = $sprout->DNASeq(\@locList);                  $fastaData = $sprout->DNASeq(\@locList);
1089                    Trace(length $fastaData . " characters returned for DNA of $fastaLabel.") if T(3);
1090              }              }
1091          }          }
     } elsif ($incomingType =~ /prot/ && $desiredType =~ /dna/) {  
         # Here we're being asked to do an impossible conversion.  
         $self->SetMessage("Cannot convert a protein sequence to DNA.");  
1092      } else {      } else {
1093            Trace("Analyzing FASTA sequence.") if T(4);
1094          # 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.
1095          if ($sequence =~ /^>\s*(\S.*)\s*\n(.+)$/) {          if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) {
1096                Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4);
1097              # Here we have a label, so we split it from the data.              # Here we have a label, so we split it from the data.
1098              $fastaLabel = $1;              $fastaLabel = $1;
1099              $fastaData = $2;              $fastaData = $2;
1100          } else {          } else {
1101                Trace("No label found in match to sequence:\n$sequence") if T(4);
1102              # 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
1103              # as data.              # as data.
1104              $fastaLabel = "User-specified $incomingType sequence";              $fastaLabel = "User-specified $desiredType sequence";
1105              $fastaData = $sequence;              $fastaData = $sequence;
1106          }          }
1107          # The next step is to clean the junk out of the sequence.          # The next step is to clean the junk out of the sequence.
1108          $fastaData =~ s/\n//g;          $fastaData =~ s/\n//g;
1109          $fastaData =~ s/\s+//g;          $fastaData =~ s/\s+//g;
1110          # Finally, if the user wants to convert to protein, we do it here. Note that          # Finally, verify that it's DNA if we're doing DNA stuff.
1111          # we've already prevented a conversion from protein to DNA.          if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn]/i) {
1112          if ($incomingType ne $desiredType) {              $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?");
1113              $fastaData = Sprout::Protein($fastaData);              $okFlag = 0;
1114          }          }
1115      }      }
1116      # At this point, either "$fastaLabel" and "$fastaData" have values or an error is      Trace("FASTA data sequence: $fastaData") if T(4);
1117      # in progress.      # Only proceed if no error was detected.
1118      if (defined $fastaLabel) {      if ($okFlag) {
1119          # 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
1120          # grep-split trick. The split, because of the presence of the parentheses,          # grep-split trick. The split, because of the presence of the parentheses,
1121          # includes the matched delimiters in the output list. The grep strips out          # includes the matched delimiters in the output list. The grep strips out
1122          # the empty list items that appear between the so-called delimiters, since          # the empty list items that appear between the so-called delimiters, since
1123          # the delimiters are what we want.          # the delimiters are what we want.
1124          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
1125          my $retVal = join("\n", ">$fastaLabel", @chunks, "");          $retVal = join("\n", ">$fastaLabel", @chunks, "");
1126      }      }
1127      # Return the result.      # Return the result.
1128      return $retVal;      return $retVal;
1129  }  }
1130    
1131    =head3 SubsystemTree
1132    
1133    C<< my $tree = SearchHelper::SubsystemTree($sprout, %options); >>
1134    
1135    This method creates a subsystem selection tree suitable for passing to
1136    L</SelectionTree>. Each leaf node in the tree will have a link to the
1137    subsystem display page. In addition, each node can have a radio button. The
1138    radio button alue is either C<classification=>I<string>, where I<string> is
1139    a classification string, or C<id=>I<string>, where I<string> is a subsystem ID.
1140    Thus, it can either be used to filter by a group of related subsystems or a
1141    single subsystem.
1142    
1143    =over 4
1144    
1145    =item sprout
1146    
1147    Sprout database object used to get the list of subsystems.
1148    
1149    =item options
1150    
1151    Hash containing options for building the tree.
1152    
1153    =item RETURN
1154    
1155    Returns a reference to a tree list suitable for passing to L</SelectionTree>.
1156    
1157    =back
1158    
1159    The supported options are as follows.
1160    
1161    =over 4
1162    
1163    =item radio
1164    
1165    TRUE if the tree should be configured for radio buttons. The default is FALSE.
1166    
1167    =item links
1168    
1169    TRUE if the tree should be configured for links. The default is TRUE.
1170    
1171    =back
1172    
1173    =cut
1174    
1175    sub SubsystemTree {
1176        # Get the parameters.
1177        my ($sprout, %options) = @_;
1178        # Process the options.
1179        my $optionThing = Tracer::GetOptions({ radio => 0, links => 1 }, \%options);
1180        # Read in the subsystems.
1181        my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1182                                   ['Subsystem(classification)', 'Subsystem(id)']);
1183        # Put any unclassified subsystems at the end. They will always be at the beginning, so if one
1184        # is at the end, ALL subsystems are unclassified and we don't bother.
1185        if ($#subs >= 0 && $subs[$#subs]->[0] ne '') {
1186            while ($subs[0]->[0] eq '') {
1187                my $classLess = shift @subs;
1188                push @subs, $classLess;
1189            }
1190        }
1191        # Declare the return variable.
1192        my @retVal = ();
1193        # Each element in @subs represents a leaf node, so as we loop through it we will be
1194        # producing one leaf node at a time. The leaf node is represented as a 2-tuple. The
1195        # first element is a semi-colon-delimited list of the classifications for the
1196        # subsystem. There will be a stack of currently-active classifications, which we will
1197        # compare to the incoming classifications from the end backward. A new classification
1198        # requires starting a new branch. A different classification requires closing an old
1199        # branch and starting a new one. Each classification in the stack will also contain
1200        # that classification's current branch. We'll add a fake classification at the
1201        # beginning that we can use to represent the tree as a whole.
1202        my $rootName = '<root>';
1203        # Create the classification stack. Note the stack is a pair of parallel lists,
1204        # one containing names and the other containing content.
1205        my @stackNames = ($rootName);
1206        my @stackContents = (\@retVal);
1207        # Add a null entry at the end of the subsystem list to force an unrolling.
1208        push @subs, ['', undef];
1209        # Loop through the subsystems.
1210        for my $sub (@subs) {
1211            # Pull out the classification list and the subsystem ID.
1212            my ($classString, $id) = @{$sub};
1213            Trace("Processing class \"$classString\" and subsystem $id.") if T(4);
1214            # Convert the classification string to a list with the root classification in
1215            # the front.
1216            my @classList = ($rootName, split($FIG_Config::splitter, $classString));
1217            # Find the leftmost point at which the class list differs from the stack.
1218            my $matchPoint = 0;
1219            while ($matchPoint <= $#stackNames && $matchPoint <= $#classList &&
1220                   $stackNames[$matchPoint] eq $classList[$matchPoint]) {
1221                $matchPoint++;
1222            }
1223            Trace("Match point is $matchPoint. Stack length is " . scalar(@stackNames) .
1224                  ". Class List length is " . scalar(@classList) . ".") if T(4);
1225            # Unroll the stack to the matchpoint.
1226            while ($#stackNames >= $matchPoint) {
1227                my $popped = pop @stackNames;
1228                pop @stackContents;
1229                Trace("\"$popped\" popped from stack.") if T(4);
1230            }
1231            # Start branches for any new classifications.
1232            while ($#stackNames < $#classList) {
1233                # The branch for a new classification contains its radio button
1234                # data and then a list of children. So, at this point, if radio buttons
1235                # are desired, we put them into the content.
1236                my $newLevel = scalar(@stackNames);
1237                my @newClassContent = ();
1238                if ($optionThing->{radio}) {
1239                    my $newClassString = join($FIG_Config::splitter, @classList[1..$newLevel]);
1240                    push @newClassContent, { value => "classification=$newClassString%" };
1241                }
1242                # The new classification node is appended to its parent's content
1243                # and then pushed onto the stack. First, we need the node name.
1244                my $nodeName = $classList[$newLevel];
1245                # Add the classification to its parent. This makes it part of the
1246                # tree we'll be returning to the user.
1247                push @{$stackContents[$#stackNames]}, $nodeName, \@newClassContent;
1248                # Push the classification onto the stack.
1249                push @stackContents, \@newClassContent;
1250                push @stackNames, $nodeName;
1251                Trace("\"$nodeName\" pushed onto stack.") if T(4);
1252            }
1253            # Now the stack contains all our parent branches. We add the subsystem to
1254            # the branch at the top of the stack, but only if it's NOT the dummy node.
1255            if (defined $id) {
1256                # Compute the node name from the ID.
1257                my $nodeName = $id;
1258                $nodeName =~ s/_/ /g;
1259                # Create the node's leaf hash. This depends on the value of the radio
1260                # and link options.
1261                my $nodeContent = {};
1262                if ($optionThing->{links}) {
1263                    # Compute the link value.
1264                    my $linkable = uri_escape($id);
1265                    $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;show_clusters=1;SPROUT=1";
1266                }
1267                if ($optionThing->{radio}) {
1268                    # Compute the radio value.
1269                    $nodeContent->{value} = "id=$id";
1270                }
1271                # Push the node into its parent branch.
1272                Trace("\"$nodeName\" added to node list.") if T(4);
1273                push @{$stackContents[$#stackNames]}, $nodeName, $nodeContent;
1274            }
1275        }
1276        # Return the result.
1277        return \@retVal;
1278    }
1279    
1280    
1281  =head3 NmpdrGenomeMenu  =head3 NmpdrGenomeMenu
1282    
1283  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, \%options, \@selected); >>  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>
1284    
1285  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
1286  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 1292 
1292    
1293  Name to give to the menu.  Name to give to the menu.
1294    
1295  =item options  =item multiple
1296    
1297  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.  
1298    
1299  =item selected  =item selected
1300    
# Line 913  Line 1302 
1302  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
1303  list is empty, nothing will be pre-selected.  list is empty, nothing will be pre-selected.
1304    
1305    =item rows (optional)
1306    
1307    Number of rows to display. If omitted, the default is 1 for a single-select list
1308    and 10 for a multi-select list.
1309    
1310    =item crossMenu (optional)
1311    
1312    If specified, is presumed to be the name of another genome menu whose contents
1313    are to be mutually exclusive with the contents of this menu. As a result, instead
1314    of the standard onChange event, the onChange event will deselect any entries in
1315    the other menu.
1316    
1317  =item RETURN  =item RETURN
1318    
1319  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 1324 
1324    
1325  sub NmpdrGenomeMenu {  sub NmpdrGenomeMenu {
1326      # Get the parameters.      # Get the parameters.
1327      my ($self, $menuName, $options, $selected) = @_;      my ($self, $menuName, $multiple, $selected, $rows, $cross) = @_;
1328      # Get the Sprout and CGI objects.      # Get the Sprout and CGI objects.
1329      my $sprout = $self->DB();      my $sprout = $self->DB();
1330      my $cgi = $self->Q();      my $cgi = $self->Q();
1331        # Compute the row count.
1332        if (! defined $rows) {
1333            $rows = ($multiple ? 10 : 1);
1334        }
1335        # Create the multiple tag.
1336        my $multipleTag = ($multiple ? " multiple" : "");
1337      # Get the form name.      # Get the form name.
1338      my $formName = $self->FormName();      my $formName = $self->FormName();
1339        # Check to see if we already have a genome list in memory.
1340        my $genomes = $self->{genomeList};
1341        my $groupHash;
1342        if (defined $genomes) {
1343            # We have a list ready to use.
1344            $groupHash = $genomes;
1345        } else {
1346      # Get a list of all the genomes in group order. In fact, we only need them ordered      # Get a list of all the genomes in group order. In fact, we only need them ordered
1347      # by name (genus,species,strain), but putting primary-group in front enables us to      # by name (genus,species,strain), but putting primary-group in front enables us to
1348      # take advantage of an existing index.      # take advantage of an existing index.
# Line 940  Line 1354 
1354      # Create a hash to organize the genomes by group. Each group will contain a list of      # Create a hash to organize the genomes by group. Each group will contain a list of
1355      # 2-tuples, the first element being the genome ID and the second being the genome      # 2-tuples, the first element being the genome ID and the second being the genome
1356      # name.      # name.
1357      my %groupHash = ();          my %gHash = ();
1358      for my $genome (@genomeList) {      for my $genome (@genomeList) {
1359          # Get the genome data.          # Get the genome data.
1360          my ($group, $genomeID, $genus, $species, $strain) = @{$genome};          my ($group, $genomeID, $genus, $species, $strain) = @{$genome};
1361          # Form the genome name.              # Compute and cache its name and display group.
1362          my $name = "$genus $species";              my ($name, $displayGroup) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1363          if ($strain) {                                                                  $strain);
1364              $name .= " $strain";              # Push the genome into the group's list. Note that we use the real group
1365          }              # name here, not the display group name.
1366          # Push the genome into the group's list.              push @{$gHash{$group}}, [$genomeID, $name];
1367          push @{$groupHash{$group}}, [$genomeID, $name];          }
1368            # Save the genome list for future use.
1369            $self->{genomeList} = \%gHash;
1370            $groupHash = \%gHash;
1371      }      }
1372      # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting      # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting
1373      # the supporting-genome group last.      # the supporting-genome group last.
1374      my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %groupHash;      my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %{$groupHash};
1375      push @groups, $FIG_Config::otherGroup;      push @groups, $FIG_Config::otherGroup;
1376      # Next, create a hash that specifies the pre-selected entries.      # Next, create a hash that specifies the pre-selected entries. Note that we need to deal
1377      my %selectedHash = map { $_ => 1 } @{$selected};      # with the possibility of undefined values in the incoming list.
1378      # Now it gets complicated. We need a way to mark all the NMPDR genomes.      my %selectedHash = ();
1379        if (defined $selected) {
1380            %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};
1381        }
1382        # Now it gets complicated. We need a way to mark all the NMPDR genomes. We take advantage
1383        # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes
1384        # and use that to make the selections.
1385        my $nmpdrCount = 0;
1386      # Create the type counters.      # Create the type counters.
1387      my $groupCount = 1;      my $groupCount = 1;
1388      # Compute the ID for the status display.      # Compute the ID for the status display.
# Line 967  Line 1391 
1391      my $showSelect = "showSelected($menuName, '$divID', 1000);";      my $showSelect = "showSelected($menuName, '$divID', 1000);";
1392      # If multiple selection is supported, create an onChange event.      # If multiple selection is supported, create an onChange event.
1393      my $onChange = "";      my $onChange = "";
1394      if ($options->{multiple}) {      if ($cross) {
1395            # Here we have a paired menu. Selecting something in our menu unselects it in the
1396            # other and redisplays the status of both.
1397            $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";
1398        } elsif ($multiple) {
1399            # This is an unpaired menu, so all we do is redisplay our status.
1400          $onChange = " onChange=\"$showSelect\"";          $onChange = " onChange=\"$showSelect\"";
1401      }      }
1402      # Create the SELECT tag and stuff it into the output array.      # Create the SELECT tag and stuff it into the output array.
1403      my $select = "<" . join(" ", "SELECT name=\"$menuName\"$onChange", map { " $_=\"$options->{$_}\"" } keys %{$options}) . ">";      my @lines = ("<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">");
     my @lines = ($select);  
1404      # Loop through the groups.      # Loop through the groups.
1405      for my $group (@groups) {      for my $group (@groups) {
1406          # Create the option group tag.          # Create the option group tag.
1407          my $tag = "<OPTGROUP label=\"$group\">";          my $tag = "<OPTGROUP label=\"$group\">";
1408          push @lines, "  $tag";          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");  
1409          # Get the genomes in the group.          # Get the genomes in the group.
1410          for my $genome (@{$groupHash{$group}}) {          for my $genome (@{$groupHash->{$group}}) {
1411                # Count this organism if it's NMPDR.
1412                if ($group ne $FIG_Config::otherGroup) {
1413                    $nmpdrCount++;
1414                }
1415                # Get the organism ID and name.
1416              my ($genomeID, $name) = @{$genome};              my ($genomeID, $name) = @{$genome};
1417              # See if it's selected.              # See if it's selected.
1418              my $select = ($selectedHash{$genomeID} ? " selected" : "");              my $select = ($selectedHash{$genomeID} ? " selected" : "");
1419              # Generate the option tag.              # Generate the option tag.
1420              my $optionTag = "<OPTION value=\"$genomeID\" label=\"$label\"$select>$name <em>($genomeID)</em></OPTION>";              my $optionTag = "<OPTION value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";
1421              push @lines, "    $optionTag";              push @lines, "    $optionTag";
1422          }          }
1423          # Close the option group.          # Close the option group.
# Line 999  Line 1426 
1426      # Close the SELECT tag.      # Close the SELECT tag.
1427      push @lines, "</SELECT>";      push @lines, "</SELECT>";
1428      # Check for multiple selection.      # Check for multiple selection.
1429      if ($options->{multiple}) {      if ($multiple) {
1430          # Since multi-select is on, we can set up some buttons to set and clear selections.          # Multi-select is on, so we need to add some selection helpers. First is
1431            # the search box. This allows the user to type text and have all genomes containing
1432            # the text selected automatically.
1433            my $searchThingName = "${menuName}_SearchThing";
1434            push @lines, "<br />" .
1435                         "<INPUT type=\"button\" name=\"Search\" class=\"button\" value=\"Select genomes containing\" onClick=\"selectViaSearch($menuName, $searchThingName); $showSelect\" />&nbsp;" .
1436                         "<INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />";
1437            # Next are the buttons to set and clear selections.
1438          push @lines, "<br />";          push @lines, "<br />";
         push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";  
1439          push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";          push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";
1440          push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\"  value=\"Select NMPDR\" onClick=\"selectSome($menuName, 'nmpdr'); $showSelect\" />";          push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";
1441          push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, 'other'); $showSelect\" />";          push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\"  value=\"Select NMPDR\" onClick=\"selectSome($menuName, $nmpdrCount, true); $showSelect\" />";
1442            push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, $nmpdrCount, false); $showSelect\" />";
1443          # Add the status display, too.          # Add the status display, too.
1444          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";
1445          # Queue to update the status display when the form loads. We need to modify the show statement          # Queue to update the status display when the form loads. We need to modify the show statement
# Line 1014  Line 1448 
1448          # in case we decide to twiddle the parameters.          # in case we decide to twiddle the parameters.
1449          $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;          $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;
1450          $self->QueueFormScript($showSelect);          $self->QueueFormScript($showSelect);
1451            # Finally, add this parameter to the list of genome parameters. This enables us to
1452            # easily find all the parameters used to select one or more genomes.
1453            push @{$self->{genomeParms}}, $menuName;
1454      }      }
1455      # Assemble all the lines into a string.      # Assemble all the lines into a string.
1456      my $retVal = join("\n", @lines, "");      my $retVal = join("\n", @lines, "");
# Line 1021  Line 1458 
1458      return $retVal;      return $retVal;
1459  }  }
1460    
1461    =head3 PropertyMenu
1462    
1463    C<< my $htmlText = $shelp->PropertyMenu($menuName, $selected, $force); >>
1464    
1465    Generate a property name dropdown menu.
1466    
1467    =over 4
1468    
1469    =item menuName
1470    
1471    Name to give to the menu.
1472    
1473    =item selected
1474    
1475    Value of the property name to pre-select.
1476    
1477    =item force (optional)
1478    
1479    If TRUE, then the user will be forced to choose a property name. If FALSE,
1480    then an additional menu choice will be provided to select nothing.
1481    
1482    =item RETURN
1483    
1484    Returns a dropdown menu box that allows the user to select a property name. An additional
1485    selection entry will be provided for selecting no property name
1486    
1487    =back
1488    
1489    =cut
1490    
1491    sub PropertyMenu {
1492        # Get the parameters.
1493        my ($self, $menuName, $selected, $force) = @_;
1494        # Get the CGI and Sprout objects.
1495        my $sprout = $self->DB();
1496        my $cgi = $self->Q();
1497        # Create the property name list.
1498        my @propNames = ();
1499        if (! $force) {
1500            push @propNames, "";
1501        }
1502        # Get all the property names, putting them after the null choice if one exists.
1503        push @propNames, $sprout->GetChoices('Property', 'property-name');
1504        # Create a menu from them.
1505        my $retVal = $cgi->popup_menu(-name=> $menuName, -values => \@propNames,
1506                                      -default => $selected);
1507        # Return the result.
1508        return $retVal;
1509    }
1510    
1511  =head3 MakeTable  =head3 MakeTable
1512    
1513  C<< my $htmlText = $shelp->MakeTable(\@rows); >>  C<< my $htmlText = $shelp->MakeTable(\@rows); >>
# Line 1039  Line 1526 
1526  =item rows  =item rows
1527    
1528  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
1529  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
1530  set the width. Everything else will be left as is.  will be modified to set the width. Everything else will be left as is.
1531    
1532  =item RETURN  =item RETURN
1533    
# Line 1055  Line 1542 
1542      my ($self, $rows) = @_;      my ($self, $rows) = @_;
1543      # Get the CGI object.      # Get the CGI object.
1544      my $cgi = $self->Q();      my $cgi = $self->Q();
1545      # 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.
1546        # This flag will be set to FALSE when that happens.
1547        my $needWidth = 1;
1548      # 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
1549      # is already specified on the first column bad things will happen.      # is already specified on the first column bad things will happen.
1550      for my $row (@{$rows}) {      for my $row (@{$rows}) {
1551          $row =~ s/(<td|th)/$1 width="150"/i;          # See if this row needs a width.
1552            if ($needWidth && $row =~ /<(td|th) ([^>]+)>/i) {
1553                # Here we have a first cell and its tag parameters are in $2.
1554                my $elements = $2;
1555                if ($elements !~ /colspan/i) {
1556                    Trace("No colspan tag found in element \'$elements\'.") if T(3);
1557                    # Here there's no colspan, so we plug in the width. We
1558                    # eschew the "g" modifier on the substitution because we
1559                    # only want to update the first cell.
1560                    $row =~ s/(<(td|th))/$1 width="150"/i;
1561                    # Denote we don't need this any more.
1562                    $needWidth = 0;
1563                }
1564            }
1565      }      }
1566      # Create the table.      # Create the table.
1567      my $retVal = $cgi->table({border => 2, cellspacing => 2,      my $retVal = $cgi->table({border => 2, cellspacing => 2,
# Line 1071  Line 1573 
1573    
1574  =head3 SubmitRow  =head3 SubmitRow
1575    
1576  C<< my $htmlText = $shelp->SubmitRow(); >>  C<< my $htmlText = $shelp->SubmitRow($caption); >>
1577    
1578  Returns the HTML text for the row containing the page size control  Returns the HTML text for the row containing the page size control
1579  and the submit button. All searches should have this row somewhere  and the submit button. All searches should have this row somewhere
1580  near the top of the form.  near the top of the form.
1581    
1582    =over 4
1583    
1584    =item caption (optional)
1585    
1586    Caption to be put on the search button. The default is C<Go>.
1587    
1588    =item RETURN
1589    
1590    Returns a table row containing the controls for submitting the search
1591    and tuning the results.
1592    
1593    =back
1594    
1595  =cut  =cut
1596    
1597  sub SubmitRow {  sub SubmitRow {
1598      # Get the parameters.      # Get the parameters.
1599      my ($self) = @_;      my ($self, $caption) = @_;
1600      my $cgi = $self->Q();      my $cgi = $self->Q();
1601      # Declare the return variable.      # Compute the button caption.
1602        my $realCaption = (defined $caption ? $caption : 'Go');
1603        # Get the current page size.
1604        my $pageSize = $cgi->param('PageSize');
1605        # Get the incoming external-link flag.
1606        my $aliases = ($cgi->param('ShowAliases') ? 1 : 0);
1607        # Create the row.
1608      my $retVal = $cgi->Tr($cgi->td("Results/Page"),      my $retVal = $cgi->Tr($cgi->td("Results/Page"),
1609                            $cgi->td($cgi->popup_menu(-name => 'PageSize',                            $cgi->td($cgi->popup_menu(-name => 'PageSize',
1610                                                      -values => [10, 25, 45, 100, 1000],                                                      -values => [10, 25, 50, 100, 1000],
1611                                                      -default => $cgi->param('PageSize'))),                                                      -default => $pageSize)),
1612                            $cgi->td($cgi->submit(-class => 'goButton',                            $cgi->td($cgi->submit(-class => 'goButton',
1613                                                  -name => 'Search',                                                  -name => 'Search',
1614                                                  -value => 'Go')));                                                  -value => $realCaption)));
1615      # Return the result.      # Return the result.
1616      return $retVal;      return $retVal;
1617  }  }
1618    
1619    =head3 FeatureFilterRows
1620    
1621    C<< my $htmlText = $shelp->FeatureFilterRows(@subset); >>
1622    
1623    This method creates table rows that can be used to filter features. The form
1624    values can be used to select features by genome using the B<FeatureQuery>
1625    object.
1626    
1627    =over 4
1628    
1629    =item subset
1630    
1631    List of rows to display. The default (C<all>) is to display all rows.
1632    C<words> displays the word search box, C<subsys> displays the subsystem
1633    selector, and C<options> displays the options row.
1634    
1635    =item RETURN
1636    
1637    Returns the html text for table rows containing the desired feature filtering controls.
1638    
1639    =back
1640    
1641    =cut
1642    
1643    sub FeatureFilterRows {
1644        # Get the parameters.
1645        my ($self, @subset) = @_;
1646        if (@subset == 0 || $subset[0] eq 'all') {
1647            @subset = qw(words subsys options);
1648        }
1649        # Return the result.
1650        return FeatureQuery::FilterRows($self, @subset);
1651    }
1652    
1653  =head3 GBrowseFeatureURL  =head3 GBrowseFeatureURL
1654    
1655  C<< my $url = SearchHelper::GBrowseFeatureURL($sprout, $feat); >>  C<< my $url = SearchHelper::GBrowseFeatureURL($sprout, $feat); >>
# Line 1133  Line 1689 
1689          # Get the feature location string.          # Get the feature location string.
1690          my $loc = $sprout->FeatureLocation($feat);          my $loc = $sprout->FeatureLocation($feat);
1691          # Compute the contig, start, and stop points.          # Compute the contig, start, and stop points.
1692          my($start, $stop, $contig) = BasicLocation::Parse($loc);          my($contig, $start, $stop) = BasicLocation::Parse($loc);
1693            Trace("Start and stop are ($start,$stop) on contig $contig.") if T(3);
1694          # Now we need to do some goofiness to insure that the location is not too          # Now we need to do some goofiness to insure that the location is not too
1695          # big and that we get some surrounding stuff.          # big and that we get some surrounding stuff.
1696          my $mid = int(($start + $stop) / 2);          my $mid = int(($start + $stop) / 2);
# Line 1163  Line 1720 
1720          }          }
1721          my $seg_id = $contig;          my $seg_id = $contig;
1722          $seg_id =~ s/:/--/g;          $seg_id =~ s/:/--/g;
1723            Trace("Show limits are ($show_start,$show_stop) in genome $genomeID with ref $seg_id.") if T(3);
1724          # Assemble all the pieces.          # Assemble all the pieces.
1725          $retVal = "gbrowse.cgi/GB_$genomeID?ref=$seg_id&start=$show_start&stop=$show_stop";          $retVal = "gbrowse.cgi/GB_$genomeID?ref=$seg_id;start=$show_start;stop=$show_stop";
1726      }      }
1727      # Return the result.      # Return the result.
1728      return $retVal;      return $retVal;
1729  }  }
1730    
1731  =head2 Feature Column Methods  =head3 GetGenomes
1732    
1733  The methods in this column manage feature column data. If you want to provide the  C<< my @genomeList = $shelp->GetGenomes($parmName); >>
 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.  
1734    
1735  There is one special column name syntax for extra columns (that is, nonstandard  Return the list of genomes specified by the specified CGI query parameter.
1736  feature columns). If the column name begins with C<X=>, then it is presumed to be  If the request method is POST, then the list of genome IDs is returned
1737  an extra column. The column title is the text after the C<X=>, and its value is  without preamble. If the request method is GET and the parameter is not
1738  pulled from the extra column hash.  specified, then it is treated as a request for all genomes. This makes it
1739    easier for web pages to link to a search that wants to specify all genomes.
1740    
1741  =head3 DefaultFeatureColumns  =over 4
1742    
1743    =item parmName
1744    
1745    Name of the parameter containing the list of genomes. This will be the
1746    first parameter passed to the L</NmpdrGenomeMenu> call that created the
1747    genome selection control on the form.
1748    
1749    =item RETURN
1750    
1751    Returns a list of the genomes to process.
1752    
1753  C<< my $colNames = $shelp->DefaultFeatureColumns(); >>  =back
1754    
1755    =cut
1756    
1757    sub GetGenomes {
1758        # Get the parameters.
1759        my ($self, $parmName) = @_;
1760        # Get the CGI query object.
1761        my $cgi = $self->Q();
1762        # Get the list of genome IDs in the request header.
1763        my @retVal = $cgi->param($parmName);
1764        Trace("Genome list for $parmName is (" . join(", ", @retVal) . ") with method " . $cgi->request_method() . ".") if T(3);
1765        # Check for the special GET case.
1766        if ($cgi->request_method() eq "GET" && ! @retVal) {
1767            # Here the caller wants all the genomes.
1768            my $sprout = $self->DB();
1769            @retVal = $sprout->Genomes();
1770        }
1771        # Return the result.
1772        return @retVal;
1773    }
1774    
1775    =head3 GetHelpText
1776    
1777    C<< my $htmlText = $shelp->GetHelpText(); >>
1778    
1779  Return a reference to a list of the default feature column identifiers. These  Get the help text for this search. The help text is stored in files on the template
1780  identifiers can be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in  server. The help text for a specific search is taken from a file named
1781  order to produce the column titles and row values.  C<SearchHelp_>I<class>C<.inc> in the template directory C<$FIG_Config::template_url>.
1782    There are also three standard help files: C<SearchHelp1_Filtering.inc> describes the
1783    feature filtering performed by the B<FeatureQuery> object, C<SearchHelp1_GenomeControl.inc>
1784    describes how to use a multiple-selection genome control, and C<SearchHelp1_Standard.inc>
1785    describes the standard controls for a search, such as page size, URL display, and
1786    external alias display.
1787    
1788  =cut  =cut
1789    
1790  sub DefaultFeatureColumns {  sub GetHelpText {
1791      # Get the parameters.      # Get the parameters.
1792      my ($self) = @_;      my ($self) = @_;
1793        # Create a list to hold the pieces of the help.
1794        my @helps = ();
1795        # Get the template directory URL.
1796        my $urlBase = $FIG_Config::template_url;
1797        # Start with the specific help.
1798        my $class = $self->{class};
1799        push @helps, PageBuilder::GetPage("$urlBase/SearchHelp_$class.inc");
1800        # Add the genome control help if needed.
1801        if (scalar @{$self->{genomeParms}}) {
1802            push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_GenomeControl.inc");
1803        }
1804        # Next the filter help.
1805        if ($self->{filtered}) {
1806            push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Filtering.inc");
1807        }
1808        # Finally, the standard help.
1809        push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Standard.inc");
1810        # Assemble the pieces.
1811        my $retVal = join("\n<p>&nbsp;</p>\n", @helps);
1812      # Return the result.      # Return the result.
1813      return ['orgName', 'function', 'gblink', 'protlink'];      return $retVal;
1814  }  }
1815    
1816  =head3 FeatureColumnTitle  =head3 ComputeSearchURL
1817    
1818  C<< my $title = $shelp->FeatureColumnTitle($colName); >>  C<< my $url = $shelp->ComputeSearchURL(%overrides); >>
1819    
1820  Return the column heading title to be used for the specified feature column.  Compute the GET-style URL for the current search. In order for this to work, there
1821    must be a copy of the search form on the current page. This will always be the
1822    case if the search is coming from C<SearchSkeleton.cgi>.
1823    
1824    A little expense is involved in order to make the URL as smart as possible. The
1825    main complication is that if the user specified all genomes, we'll want to
1826    remove the parameter entirely from a get-style URL.
1827    
1828  =over 4  =over 4
1829    
1830  =item name  =item overrides
1831    
1832  Name of the desired feature column.  Hash containing override values for the parameters, where the parameter name is
1833    the key and the parameter value is the override value. If the override value is
1834    C<undef>, the parameter will be deleted from the result.
1835    
1836  =item RETURN  =item RETURN
1837    
1838  Returns the title to be used as the column header for the named feature column.  Returns a GET-style URL for invoking the search with the specified overrides.
1839    
1840  =back  =back
1841    
1842  =cut  =cut
1843    
1844  sub FeatureColumnTitle {  sub ComputeSearchURL {
1845      # Get the parameters.      # Get the parameters.
1846      my ($self, $colName) = @_;      my ($self, %overrides) = @_;
1847      # Declare the return variable. We default to a blank column name.      # Get the database and CGI query object.
1848      my $retVal = "&nbsp;";      my $cgi = $self->Q();
1849      # Process the column name.      my $sprout = $self->DB();
1850      if ($colName =~ /^X=(.+)$/) {      # Start with the full URL.
1851          # Here we have an extra column.      my $retVal = $cgi->url(-full => 1);
1852          $retVal = $1;      # Get all the query parameters in a hash.
1853      } elsif ($colName eq 'orgName') {      my %parms = $cgi->Vars();
1854          $retVal = "Name";      # Now we need to do some fixing. Each multi-valued parameter is encoded as a string with null
1855      } elsif ($colName eq 'fid') {      # characters separating the individual values. We have to convert those to lists. In addition,
1856          $retVal = "FIG ID";      # the multiple-selection genome parameters and the feature type parameter must be checked to
1857        # determine whether or not they can be removed from the URL. First, we get a list of the
1858        # genome parameters and a list of all genomes. Note that we only need the list if a
1859        # multiple-selection genome parameter has been found on the form.
1860        my %genomeParms = map { $_ => 1 } @{$self->{genomeParms}};
1861        my @genomeList;
1862        if (keys %genomeParms) {
1863            @genomeList = $sprout->Genomes();
1864        }
1865        # Create a list to hold the URL parameters we find.
1866        my @urlList = ();
1867        # Now loop through the parameters in the hash, putting them into the output URL.
1868        for my $parmKey (keys %parms) {
1869            # Get a list of the parameter values. If there's only one, we'll end up with
1870            # a singleton list, but that's okay.
1871            my @values = split (/\0/, $parms{$parmKey});
1872            # Check for special cases.
1873            if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) {
1874                # These are bookkeeping parameters we don't need to start a search.
1875                @values = ();
1876            } elsif ($parmKey =~ /_SearchThing$/) {
1877                # Here the value coming in is from a genome control's search thing. It does
1878                # not affect the results of the search, so we clear it.
1879                @values = ();
1880            } elsif ($genomeParms{$parmKey}) {
1881                # Here we need to see if the user wants all the genomes. If he does,
1882                # we erase all the values just like with features.
1883                my $allFlag = $sprout->IsAllGenomes(\@values, \@genomeList);
1884                if ($allFlag) {
1885                    @values = ();
1886                }
1887            } elsif (exists $overrides{$parmKey}) {
1888                # Here the value is being overridden, so we skip it for now.
1889                @values = ();
1890            }
1891            # If we still have values, create the URL parameters.
1892            if (@values) {
1893                push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1894            }
1895        }
1896        # Now do the overrides.
1897        for my $overKey (keys %overrides) {
1898            # Only use this override if it's not a delete marker.
1899            if (defined $overrides{$overKey}) {
1900                push @urlList, "$overKey=" . uri_escape($overrides{$overKey});
1901            }
1902        }
1903        # Add the parameters to the URL.
1904        $retVal .= "?" . join(";", @urlList);
1905        # Return the result.
1906        return $retVal;
1907    }
1908    
1909    =head3 GetRunTimeValue
1910    
1911    C<< my $htmlText = $shelp->GetRunTimeValue($text); >>
1912    
1913    Compute a run-time column value.
1914    
1915    =over 4
1916    
1917    =item text
1918    
1919    The run-time column text. It consists of 2 percent signs, a column type, an equal
1920    sign, and the data for the current row.
1921    
1922    =item RETURN
1923    
1924    Returns the fully-formatted HTML text to go into the current column of the current row.
1925    
1926    =back
1927    
1928    =cut
1929    
1930    sub GetRunTimeValue {
1931        # Get the parameters.
1932        my ($self, $text) = @_;
1933        # Declare the return variable.
1934        my $retVal;
1935        # Parse the incoming text.
1936        if ($text =~ /^%%([^=]+)=(.*)$/) {
1937            $retVal = $self->RunTimeColumns($1, $2);
1938        } else {
1939            Confess("Invalid run-time column string \"$text\" encountered in session file.");
1940        }
1941        # Return the result.
1942        return $retVal;
1943    }
1944    
1945    =head3 AdvancedClassList
1946    
1947    C<< my @classes = SearchHelper::AdvancedClassList(); >>
1948    
1949    Return a list of advanced class names. This list is used to generate the directory
1950    of available searches on the search page.
1951    
1952    We use the %INC variable to accomplish this.
1953    
1954    =cut
1955    
1956    sub AdvancedClassList {
1957        my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;
1958        return @retVal;
1959    }
1960    
1961    =head3 SelectionTree
1962    
1963    C<< my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options); >>
1964    
1965    Display a selection tree.
1966    
1967    This method creates the HTML for a tree selection control. The tree is implemented as a set of
1968    nested HTML unordered lists. Each selectable element of the tree will contain a radio button. In
1969    addition, some of the tree nodes can contain hyperlinks.
1970    
1971    The tree itself is passed in as a multi-level list containing node names followed by
1972    contents. Each content element is a reference to a similar list. The first element of
1973    each list may be a hash reference. If so, it should contain one or both of the following
1974    keys.
1975    
1976    =over 4
1977    
1978    =item link
1979    
1980    The navigation URL to be popped up if the user clicks on the node name.
1981    
1982    =item value
1983    
1984    The form value to be returned if the user selects the tree node.
1985    
1986    =back
1987    
1988    The presence of a C<link> key indicates the node name will be hyperlinked. The presence of
1989    a C<value> key indicates the node name will have a radio button. If a node has no children,
1990    you may pass it a hash reference instead of a list reference.
1991    
1992    The following example shows the hash for a three-level tree with links on the second level and
1993    radio buttons on the third.
1994    
1995        [   Objects => [
1996                Entities => [
1997                    {link => "../docs/WhatIsAnEntity.html"},
1998                    Genome => {value => 'GenomeData'},
1999                    Feature => {value => 'FeatureData'},
2000                    Contig => {value => 'ContigData'},
2001                ],
2002                Relationships => [
2003                    {link => "../docs/WhatIsARelationShip.html"},
2004                    HasFeature => {value => 'GenomeToFeature'},
2005                    IsOnContig => {value => 'FeatureToContig'},
2006                ]
2007            ]
2008        ]
2009    
2010    Note how each leaf of the tree has a hash reference for its value, while the branch nodes
2011    all have list references.
2012    
2013    This next example shows how to set up a taxonomy selection field. The value returned
2014    by the tree control will be the taxonomy string for the selected node ready for use
2015    in a LIKE-style SQL filter. Only the single branch ending in campylobacter is shown for
2016    reasons of space.
2017    
2018        [   All => [
2019                {value => "%"},
2020                Bacteria => [
2021                    {value => "Bacteria%"},
2022                    Proteobacteria => [
2023                        {value => "Bacteria; Proteobacteria%"},
2024                        Epsilonproteobacteria => [
2025                            {value => "Bacteria; Proteobacteria;Epsilonproteobacteria%"},
2026                            Campylobacterales => [
2027                                {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales%"},
2028                                Campylobacteraceae =>
2029                                    {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales; Campylobacteraceae%"},
2030                                ...
2031                            ]
2032                            ...
2033                        ]
2034                        ...
2035                    ]
2036                    ...
2037                ]
2038                ...
2039            ]
2040        ]
2041    
2042    
2043    This method of tree storage allows the caller to control the order in which the tree nodes
2044    are displayed and to completely control value selection and use of hyperlinks. It is, however
2045    a bit complicated. Eventually, tree-building classes will be provided to simplify things.
2046    
2047    The parameters to this method are as follows.
2048    
2049    =over 4
2050    
2051    =item cgi
2052    
2053    CGI object used to generate the HTML.
2054    
2055    =item tree
2056    
2057    Reference to a hash describing a tree. See the description above.
2058    
2059    =item options
2060    
2061    Hash containing options for the tree display.
2062    
2063    =back
2064    
2065    The allowable options are as follows
2066    
2067    =over 4
2068    
2069    =item nodeImageClosed
2070    
2071    URL of the image to display next to the tree nodes when they are collapsed. Clicking
2072    on the image will expand a section of the tree. The default is C<../FIG/Html/plus.gif>.
2073    
2074    =item nodeImageOpen
2075    
2076    URL of the image to display next to the tree nodes when they are expanded. Clicking
2077    on the image will collapse a section of the tree. The default is C<../FIG/Html/minus.gif>.
2078    
2079    =item style
2080    
2081    Style to use for the tree. The default is C<tree>. Because the tree style is implemented
2082    as nested lists, the key components of this style are the definitions for the C<ul> and
2083    C<li> tags. The default style file contains the following definitions.
2084    
2085        .tree ul {
2086           margin-left: 0; padding-left: 22px
2087        }
2088        .tree li {
2089            list-style-type: none;
2090        }
2091    
2092    The default image is 22 pixels wide, so in the above scheme each tree level is indented from its
2093    parent by the width of the node image. This use of styles limits the things we can do in formatting
2094    the tree, but it has the advantage of vastly simplifying the tree creation.
2095    
2096    =item name
2097    
2098    Field name to give to the radio buttons in the tree. The default is C<selection>.
2099    
2100    =item target
2101    
2102    Frame target for links. The default is C<_self>.
2103    
2104    =item selected
2105    
2106    If specified, the value of the radio button to be pre-selected.
2107    
2108    =back
2109    
2110    =cut
2111    
2112    sub SelectionTree {
2113        # Get the parameters.
2114        my ($cgi, $tree, %options) = @_;
2115        # Get the options.
2116        my $optionThing = Tracer::GetOptions({ name => 'selection',
2117                                               nodeImageClosed => '../FIG/Html/plus.gif',
2118                                               nodeImageOpen => '../FIG/Html/minus.gif',
2119                                               style => 'tree',
2120                                               target => '_self',
2121                                               selected => undef},
2122                                             \%options);
2123        # Declare the return variable. We'll do the standard thing with creating a list
2124        # of HTML lines and rolling them together at the end.
2125        my @retVal = ();
2126        # Only proceed if the tree is present.
2127        if (defined($tree)) {
2128            # Validate the tree.
2129            if (ref $tree ne 'ARRAY') {
2130                Confess("Selection tree is not a list reference.");
2131            } elsif (scalar @{$tree} == 0) {
2132                # The tree is empty, so we do nothing.
2133            } elsif ($tree->[0] eq 'HASH') {
2134                Confess("Hash reference found at start of selection tree. The tree as a whole cannot have attributes, only tree nodes.");
2135            } else {
2136                # Here we have a real tree. Apply the tree style.
2137                push @retVal, $cgi->start_div({ class => $optionThing->{style} });
2138                # Give us a DIV ID.
2139                my $divID = GetDivID($optionThing->{name});
2140                # Show the tree.
2141                push @retVal, ShowBranch($cgi, "(root)", $divID, $tree, $optionThing, 'block');
2142                # Close the DIV block.
2143                push @retVal, $cgi->end_div();
2144            }
2145        }
2146        # Return the result.
2147        return join("\n", @retVal, "");
2148    }
2149    
2150    =head3 ShowBranch
2151    
2152    C<< my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType); >>
2153    
2154    This is a recursive method that displays a branch of the tree.
2155    
2156    =over 4
2157    
2158    =item cgi
2159    
2160    CGI object used to format HTML.
2161    
2162    =item label
2163    
2164    Label of this tree branch. It is only used in error messages.
2165    
2166    =item id
2167    
2168    ID to be given to this tree branch. The ID is used in the code that expands and collapses
2169    tree nodes.
2170    
2171    =item branch
2172    
2173    Reference to a list containing the content of the tree branch. The list contains an optional
2174    hash reference that is ignored and the list of children, each child represented by a name
2175    and then its contents. The contents could by a hash reference (indicating the attributes
2176    of a leaf node), or another tree branch.
2177    
2178    =item options
2179    
2180    Options from the original call to L</SelectionTree>.
2181    
2182    =item displayType
2183    
2184    C<block> if the contents of this list are to be displayed, C<none> if they are to be
2185    hidden.
2186    
2187    =item RETURN
2188    
2189    Returns one or more HTML lines that can be used to display the tree branch.
2190    
2191    =back
2192    
2193    =cut
2194    
2195    sub ShowBranch {
2196        # Get the parameters.
2197        my ($cgi, $label, $id, $branch, $options, $displayType) = @_;
2198        # Declare the return variable.
2199        my @retVal = ();
2200        # Start the branch.
2201        push @retVal, $cgi->start_ul({ id => $id, style => "display:$displayType" });
2202        # Check for the hash and choose the start location accordingly.
2203        my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0);
2204        # Get the list length.
2205        my $i1 = scalar(@{$branch});
2206        # Verify we have an even number of elements.
2207        if (($i1 - $i0) % 2 != 0) {
2208            Trace("Branch elements are from $i0 to $i1.") if T(3);
2209            Confess("Odd number of elements in tree branch $label.");
2210        } else {
2211            # Loop through the elements.
2212            for (my $i = $i0; $i < $i1; $i += 2) {
2213                # Get this node's label and contents.
2214                my ($myLabel, $myContent) = ($branch->[$i], $branch->[$i+1]);
2215                # Get an ID for this node's children (if any).
2216                my $myID = GetDivID($options->{name});
2217                # Now we need to find the list of children and the options hash.
2218                # This is a bit ugly because we allow the shortcut of a hash without an
2219                # enclosing list. First, we need some variables.
2220                my $attrHash = {};
2221                my @childHtml = ();
2222                my $hasChildren = 0;
2223                if (! ref $myContent) {
2224                    Confess("Invalid tree definition. Scalar found as content of node \"$myLabel\".");
2225                } elsif (ref $myContent eq 'HASH') {
2226                    # Here the node is a leaf and its content contains the link/value hash.
2227                    $attrHash = $myContent;
2228                } elsif (ref $myContent eq 'ARRAY') {
2229                    # Here the node may be a branch. Its content is a list.
2230                    my $len = scalar @{$myContent};
2231                    if ($len >= 1) {
2232                        # Here the first element of the list could by the link/value hash.
2233                        if (ref $myContent->[0] eq 'HASH') {
2234                            $attrHash = $myContent->[0];
2235                            # If there's data in the list besides the hash, it's our child list.
2236                            # We can pass the entire thing as the child list, because the hash
2237                            # is ignored.
2238                            if ($len > 1) {
2239                                $hasChildren = 1;
2240                            }
2241                        } else {
2242                            $hasChildren = 1;
2243                        }
2244                        # If we have children, create the child list with a recursive call.
2245                        if ($hasChildren) {
2246                            Trace("Processing children of $myLabel.") if T(4);
2247                            push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2248                            Trace("Children of $myLabel finished.") if T(4);
2249                        }
2250                    }
2251                }
2252                # Okay, it's time to pause and take stock. We have the label of the current node
2253                # in $myLabel, its attributes in $attrHash, and if it is NOT a leaf node, we
2254                # have a child list in @childHtml. If it IS a leaf node, $hasChildren is 0.
2255                # Compute the image HTML. It's tricky, because we have to deal with the open and
2256                # closed images.
2257                my @images = ($options->{nodeImageOpen}, $options->{nodeImageClosed});
2258                my $image = $images[$hasChildren];
2259                my $prefixHtml = $cgi->img({src => $image, id => "${myID}img"});
2260                if ($hasChildren) {
2261                    # If there are children, we wrap the image in a toggle hyperlink.
2262                    $prefixHtml = $cgi->a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" },
2263                                          $prefixHtml);
2264                }
2265                # Now the radio button, if any. Note we use "defined" in case the user wants the
2266                # value to be 0.
2267                if (defined $attrHash->{value}) {
2268                    # Due to a glitchiness in the CGI stuff, we have to build the attribute
2269                    # hash for the "input" method. If the item is pre-selected, we add
2270                    # "checked => undef" to the hash. Otherwise, we can't have "checked"
2271                    # at all.
2272                    my $radioParms = { type => 'radio',
2273                                       name => $options->{name},
2274                                       value => $attrHash->{value},
2275                                     };
2276                    if (defined $options->{selected} && $options->{selected} eq $attrHash->{value}) {
2277                        $radioParms->{checked} = undef;
2278                    }
2279                    $prefixHtml .= $cgi->input($radioParms);
2280                }
2281                # Next, we format the label.
2282                my $labelHtml = $myLabel;
2283                Trace("Formatting tree node for \"$myLabel\".") if T(4);
2284                # Apply a hyperlink if necessary.
2285                if (defined $attrHash->{link}) {
2286                    $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
2287                                         $labelHtml);
2288                }
2289                # Finally, roll up the child HTML. If there are no children, we'll get a null string
2290                # here.
2291                my $childHtml = join("\n", @childHtml);
2292                # Now we have all the pieces, so we can put them together.
2293                push @retVal, $cgi->li("$prefixHtml$labelHtml$childHtml");
2294            }
2295        }
2296        # Close the tree branch.
2297        push @retVal, $cgi->end_ul();
2298        # Return the result.
2299        return @retVal;
2300    }
2301    
2302    =head3 GetDivID
2303    
2304    C<< my $idString = SearchHelper::GetDivID($name); >>
2305    
2306    Return a new HTML ID string.
2307    
2308    =over 4
2309    
2310    =item name
2311    
2312    Name to be prefixed to the ID string.
2313    
2314    =item RETURN
2315    
2316    Returns a hopefully-unique ID string.
2317    
2318    =back
2319    
2320    =cut
2321    
2322    sub GetDivID {
2323        # Get the parameters.
2324        my ($name) = @_;
2325        # Compute the ID.
2326        my $retVal = "elt_$name$divCount";
2327        # Increment the counter to make sure this ID is not re-used.
2328        $divCount++;
2329        # Return the result.
2330        return $retVal;
2331    }
2332    
2333    =head2 Feature Column Methods
2334    
2335    The methods in this section manage feature column data. If you want to provide the
2336    capability to include new types of data in feature columns, then all the changes
2337    are made to this section of the source file. Technically, this should be implemented
2338    using object-oriented methods, but this is simpler for non-programmers to maintain.
2339    To add a new column of feature data, you must first give it a name. For example,
2340    the name for the protein page link column is C<protlink>. If the column is to appear
2341    in the default list of feature columns, add it to the list returned by
2342    L</DefaultFeatureColumns>. Then add code to produce the column title to
2343    L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>. If the
2344    feature column should be excluded from downloads, add it to the C<FeatureColumnSkip>
2345    hash. Everything else will happen automatically.
2346    
2347    There is a special column name syntax for extra columns (that is, nonstandard
2348    feature columns). If the column name begins with C<X=>, then it is presumed to be
2349    an extra column. The column title is the text after the C<X=>, and its value is
2350    pulled from the extra column hash.
2351    
2352    =cut
2353    
2354    # This hash is used to determine which columns should not be included in downloads.
2355    my %FeatureColumnSkip = map { $_ => 1 } qw(gblink viewerlink protlink);
2356    
2357    =head3 DefaultFeatureColumns
2358    
2359    C<< my @colNames = $shelp->DefaultFeatureColumns(); >>
2360    
2361    Return a list of the default feature column identifiers. These identifiers can
2362    be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in order to
2363    produce the column titles and row values.
2364    
2365    =cut
2366    
2367    sub DefaultFeatureColumns {
2368        # Get the parameters.
2369        my ($self) = @_;
2370        # Return the result.
2371        return qw(orgName function gblink protlink);
2372    }
2373    
2374    =head3 FeatureColumnTitle
2375    
2376    C<< my $title = $shelp->FeatureColumnTitle($colName); >>
2377    
2378    Return the column heading title to be used for the specified feature column.
2379    
2380    =over 4
2381    
2382    =item name
2383    
2384    Name of the desired feature column.
2385    
2386    =item RETURN
2387    
2388    Returns the title to be used as the column header for the named feature column.
2389    
2390    =back
2391    
2392    =cut
2393    
2394    sub FeatureColumnTitle {
2395        # Get the parameters.
2396        my ($self, $colName) = @_;
2397        # Declare the return variable. We default to a blank column name.
2398        my $retVal = "&nbsp;";
2399        # Process the column name.
2400        if ($colName =~ /^X=(.+)$/) {
2401            # Here we have an extra column.
2402            $retVal = $1;
2403      } elsif ($colName eq 'alias') {      } elsif ($colName eq 'alias') {
2404          $retVal = "External Aliases";          $retVal = "External Aliases";
2405        } elsif ($colName eq 'fid') {
2406            $retVal = "FIG ID";
2407      } elsif ($colName eq 'function') {      } elsif ($colName eq 'function') {
2408          $retVal = "Functional Assignment";          $retVal = "Functional Assignment";
2409      } elsif ($colName eq 'gblink') {      } elsif ($colName eq 'gblink') {
2410          $retVal = "GBrowse";          $retVal = "GBrowse";
     } elsif ($colName eq 'protlink') {  
         $retVal = "NMPDR Protein Page";  
2411      } elsif ($colName eq 'group') {      } elsif ($colName eq 'group') {
2412          $retVal = "NMDPR Group";          $retVal = "NMDPR Group";
2413        } elsif ($colName =~ /^keyword:(.+)$/) {
2414            $retVal = ucfirst $1;
2415        } elsif ($colName eq 'orgName') {
2416            $retVal = "Organism and Gene ID";
2417        } elsif ($colName eq 'protlink') {
2418            $retVal = "NMPDR Protein Page";
2419        } elsif ($colName eq 'viewerlink') {
2420            $retVal = "Annotation Page";
2421        } elsif ($colName eq 'subsystem') {
2422            $retVal = "Subsystems";
2423      }      }
2424      # Return the result.      # Return the result.
2425      return $retVal;      return $retVal;
2426  }  }
2427    
2428    =head3 FeatureColumnDownload
2429    
2430    C<< my $keep = $shelp->FeatureColumnDownload($colName); >>
2431    
2432    Return TRUE if the named feature column is to be kept when downloading, else FALSE.
2433    
2434    =over 4
2435    
2436    =item colName
2437    
2438    Name of the relevant feature column.
2439    
2440    =item RETURN
2441    
2442    Return TRUE if the named column should be kept while downloading, else FALSE. In general,
2443    FALSE is returned if the column generates a button, image, or other purely-HTML value.
2444    
2445    =back
2446    
2447    =cut
2448    
2449    sub FeatureColumnDownload {
2450        # Get the parameters.
2451        my ($self, $colName) = @_;
2452        # Return the determination. We download the column if it's not in the skip-hash.
2453        # Note we return 0 and 1 instead of 1 and undef because it simplifies some tracing.
2454        return (exists $FeatureColumnSkip{$colName} ? 0 : 1);
2455    }
2456    
2457    
2458  =head3 FeatureColumnValue  =head3 FeatureColumnValue
2459    
2460  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>
# Line 1267  Line 2469 
2469    
2470  =item record  =item record
2471    
2472  DBObject record for the feature being displayed in the current row.  ERDBObject record for the feature being displayed in the current row.
2473    
2474  =item extraCols  =item extraCols
2475    
# Line 1303  Line 2505 
2505          if (defined $extraCols->{$1}) {          if (defined $extraCols->{$1}) {
2506              $retVal = $extraCols->{$1};              $retVal = $extraCols->{$1};
2507          }          }
2508      } elsif ($colName eq 'orgName') {      } elsif ($colName eq 'alias') {
2509          # Here we want the formatted organism name and feature number.          # In this case, the user wants a list of external aliases for the feature.
2510          $retVal = $self->FeatureName($fid);          # These are very expensive, so we compute them when the row is displayed.
2511            # To do the computation, we need to know the favored alias type and the
2512            # feature ID.
2513            my $favored = $cgi->param("FavoredAlias") || "fig";
2514            $retVal = "%%alias=$fid,$favored";
2515      } elsif ($colName eq 'fid') {      } elsif ($colName eq 'fid') {
2516          # Here we have the raw feature ID. We hyperlink it to the protein page.          # Here we have the raw feature ID. We hyperlink it to the protein page.
2517          $retVal = HTML::set_prot_links($fid);          $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);  
         }  
2518      } elsif ($colName eq 'function') {      } elsif ($colName eq 'function') {
2519          # The functional assignment is just a matter of getting some text.          # The functional assignment is just a matter of getting some text.
2520          ($retVal) = $record->Value('Feature(assignment)');          ($retVal) = $record->Value('Feature(assignment)');
2521      } elsif ($colName eq 'gblink') {      } elsif ($colName eq 'gblink') {
2522          # Here we want a link to the GBrowse page using the official GBrowse button.          # Here we want a link to the GBrowse page using the official GBrowse button.
2523          my $gurl = "GetGBrowse.cgi?fid=$fid";          $retVal = FakeButton('GBrowse', "GetGBrowse.cgi", undef,
2524          $retVal = $cgi->a({ href => $gurl, title => "GBrowse for $fid" },                            fid => $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 })  
                          );  
2525      } elsif ($colName eq 'group') {      } elsif ($colName eq 'group') {
2526          # Get the NMPDR group name.          # Get the NMPDR group name.
2527          my (undef, $group) = $self->OrganismData($fid);          my (undef, $group) = $self->OrganismData($fid);
# Line 1345  Line 2529 
2529          my $nurl = $sprout->GroupPageName($group);          my $nurl = $sprout->GroupPageName($group);
2530          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },
2531                            $group);                            $group);
2532        } elsif ($colName =~ /^keyword:(.+)$/) {
2533            # Here we want keyword-related values. This is also expensive, so
2534            # we compute them when the row is displayed.
2535            $retVal = "%%$colName=$fid";
2536        } elsif ($colName eq 'orgName') {
2537            # Here we want the formatted organism name and feature number.
2538            $retVal = $self->FeatureName($fid);
2539        } elsif ($colName eq 'protlink') {
2540            # Here we want a link to the protein page using the official NMPDR button.
2541            $retVal = FakeButton('NMPDR', "protein.cgi", undef,
2542                              prot => $fid, SPROUT => 1, new_framework => 0,
2543                              user => '');
2544        } elsif ($colName eq 'viewerlink') {
2545            # Here we want a link to the SEED viewer page using the official viewer button.
2546            $retVal = FakeButton('Annotation', "index.cgi", undef,
2547                                 action => 'ShowAnnotation', prot => $fid);
2548        } elsif ($colName eq 'subsystem') {
2549            # Another run-time column: subsystem list.
2550            $retVal = "%%subsystem=$fid";
2551        }
2552        # Return the result.
2553        return $retVal;
2554    }
2555    
2556    =head3 RunTimeColumns
2557    
2558    C<< my $htmlText = $shelp->RunTimeColumns($type, $text); >>
2559    
2560    Return the HTML text for a run-time column. Run-time columns are evaluated when the
2561    list is displayed, rather than when it is generated.
2562    
2563    =over 4
2564    
2565    =item type
2566    
2567    Type of column.
2568    
2569    =item text
2570    
2571    Data relevant to this row of the column.
2572    
2573    =item RETURN
2574    
2575    Returns the fully-formatted HTML text to go in the specified column.
2576    
2577    =back
2578    
2579    =cut
2580    
2581    sub RunTimeColumns {
2582        # Get the parameters.
2583        my ($self, $type, $text) = @_;
2584        # Declare the return variable.
2585        my $retVal = "";
2586        # Get the Sprout and CGI objects.
2587        my $sprout = $self->DB();
2588        my $cgi = $self->Q();
2589        Trace("Runtime column $type with text \"$text\" found.") if T(4);
2590        # Separate the text into a type and data.
2591        if ($type eq 'alias') {
2592            # Here the caller wants external alias links for a feature. The text
2593            # parameter for computing the alias is the feature ID followed by
2594            # the favored alias type.
2595            my ($fid, $favored) = split /\s*,\s*/, $text;
2596            # The complicated part is we have to hyperlink them and handle the
2597            # favorites. First, get the aliases.
2598            Trace("Generating aliases for feature $fid.") if T(4);
2599            my @aliases = sort $sprout->FeatureAliases($fid);
2600            # Only proceed if we found some.
2601            if (@aliases) {
2602                # Split the aliases into favored and unfavored.
2603                my @favored = ();
2604                my @unfavored = ();
2605                for my $alias (@aliases) {
2606                    # Use substr instead of pattern match because $favored is specified by the user
2607                    # and we don't want him to put funny meta-characters in there.
2608                    if (substr($alias, 0, length($favored)) eq $favored) {
2609                        push @favored, $alias;
2610                    } else {
2611                        push @unfavored, $alias;
2612                    }
2613                }
2614                # Rejoin the aliases into a comma-delimited list, with the favored ones first.
2615                my $aliasList = join(", ", @favored, @unfavored);
2616                # Ask the HTML processor to hyperlink them.
2617                $retVal = HTML::set_prot_links($cgi, $aliasList);
2618            }
2619        } elsif ($type eq 'subsystem') {
2620            # Here the caller wants the subsystems in which this feature participates.
2621            # The text is the feature ID. We will list the subsystem names with links
2622            # to the subsystem's summary page.
2623            my $fid = $text;
2624            # Get the subsystems.
2625            Trace("Generating subsystems for feature $fid.") if T(4);
2626            my %subs = $sprout->SubsystemsOf($fid);
2627            # Extract the subsystem names.
2628            my @names = map { HTML::sub_link($cgi, $_) } sort keys %subs;
2629            # String them into a list.
2630            $retVal = join(", ", @names);
2631        } elsif ($type =~ /^keyword:(.+)$/) {
2632            # Here the caller wants the value of the named keyword. The text is the
2633            # feature ID.
2634            my $keywordName = $1;
2635            my $fid = $text;
2636            # Get the attribute values.
2637            Trace("Getting $keywordName values for feature $fid.") if T(4);
2638            my @values = $sprout->GetFlat(['Feature'], "Feature(id) = ?", [$fid],
2639                                          "Feature($keywordName)");
2640            # String them into a list.
2641            $retVal = join(", ", @values);
2642        }
2643        # Return the result.
2644        return $retVal;
2645    }
2646    
2647    =head3 SaveOrganismData
2648    
2649    C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain); >>
2650    
2651    Format the name of an organism and the display version of its group name. The incoming
2652    data should be the relevant fields from the B<Genome> record in the database. The
2653    data will also be stored in the genome cache for later use in posting search results.
2654    
2655    =over 4
2656    
2657    =item group
2658    
2659    Name of the genome's group as it appears in the database.
2660    
2661    =item genomeID
2662    
2663    ID of the relevant genome.
2664    
2665    =item genus
2666    
2667    Genus of the genome's organism. If undefined or null, it will be assumed the genome is not
2668    in the database. In this case, the organism name is derived from the genomeID and the group
2669    is automatically the supporting-genomes group.
2670    
2671    =item species
2672    
2673    Species of the genome's organism.
2674    
2675    =item strain
2676    
2677    Strain of the species represented by the genome.
2678    
2679    =item RETURN
2680    
2681    Returns a two-element list. The first element is the formatted genome name. The second
2682    element is the display name of the genome's group.
2683    
2684    =back
2685    
2686    =cut
2687    
2688    sub SaveOrganismData {
2689        # Get the parameters.
2690        my ($self, $group, $genomeID, $genus, $species, $strain) = @_;
2691        # Declare the return values.
2692        my ($name, $displayGroup);
2693        # If the organism does not exist, format an unknown name and a blank group.
2694        if (! defined($genus)) {
2695            $name = "Unknown Genome $genomeID";
2696            $displayGroup = "";
2697        } else {
2698            # It does exist, so format the organism name.
2699            $name = "$genus $species";
2700            if ($strain) {
2701                $name .= " $strain";
2702            }
2703            # Compute the display group. This is currently the same as the incoming group
2704            # name unless it's the supporting group, which is nulled out.
2705            $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2706        }
2707        # Cache the group and organism data.
2708        my $cache = $self->{orgs};
2709        $cache->{$genomeID} = [$name, $displayGroup];
2710        # Return the result.
2711        return ($name, $displayGroup);
2712    }
2713    
2714    =head3 ValidateKeywords
2715    
2716    C<< my $okFlag = $shelp->ValidateKeywords($keywordString, $required); >>
2717    
2718    Insure that a keyword string is reasonably valid. If it is invalid, a message will be
2719    set.
2720    
2721    =over 4
2722    
2723    =item keywordString
2724    
2725    Keyword string specified as a parameter to the current search.
2726    
2727    =item required
2728    
2729    TRUE if there must be at least one keyword specified, else FALSE.
2730    
2731    =item RETURN
2732    
2733    Returns TRUE if the keyword string is valid, else FALSE. Note that a null keyword string
2734    is acceptable if the I<$required> parameter is not specified.
2735    
2736    =back
2737    
2738    =cut
2739    
2740    sub ValidateKeywords {
2741        # Get the parameters.
2742        my ($self, $keywordString, $required) = @_;
2743        # Declare the return variable.
2744        my $retVal = 0;
2745        my @wordList = split /\s+/, $keywordString;
2746        # Right now our only real worry is a list of all minus words. The problem with it is that
2747        # it will return an incorrect result.
2748        my @plusWords = grep { $_ =~ /^[^\-]/ } @wordList;
2749        if (! @wordList) {
2750            if ($required) {
2751                $self->SetMessage("No search words specified.");
2752            } else {
2753                $retVal = 1;
2754            }
2755        } elsif (! @plusWords) {
2756            $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
2757        } else {
2758            $retVal = 1;
2759      }      }
2760      # Return the result.      # Return the result.
2761      return $retVal;      return $retVal;
2762  }  }
2763    
2764    =head3 FakeButton
2765    
2766    C<< my $html = SearchHelper::FakeButton($caption, $url, $target, %parms); >>
2767    
2768    Create a fake button that hyperlinks to the specified URL with the specified parameters.
2769    Unlike a real button, this one won't visibly click, but it will take the user to the
2770    correct place.
2771    
2772    The parameters of this method are deliberately identical to L</Formlet> so that we
2773    can switch easily from real buttons to fake ones in the code.
2774    
2775    =over 4
2776    
2777    =item caption
2778    
2779    Caption to be put on the button.
2780    
2781    =item url
2782    
2783    URL for the target page or script.
2784    
2785    =item target
2786    
2787    Frame or target in which the new page should appear. If C<undef> is specified,
2788    the default target will be used.
2789    
2790    =item parms
2791    
2792    Hash containing the parameter names as keys and the parameter values as values.
2793    These will be appended to the URL.
2794    
2795    =back
2796    
2797    =cut
2798    
2799    sub FakeButton {
2800        # Get the parameters.
2801        my ($caption, $url, $target, %parms) = @_;
2802        # Declare the return variable.
2803        my $retVal;
2804        # Compute the target URL.
2805        my $targetUrl = "$url?" . join(";", map { "$_=" . uri_escape($parms{$_}) } keys %parms);
2806        # Compute the target-frame HTML.
2807        my $targetHtml = ($target ? " target=\"$target\"" : "");
2808        # Assemble the result.
2809        return "<a href=\"$targetUrl\" $targetHtml><div class=\"button2 button\">$caption</div></a>";
2810    }
2811    
2812    =head3 Formlet
2813    
2814    C<< my $html = SearchHelper::Formlet($caption, $url, $target, %parms); >>
2815    
2816    Create a mini-form that posts to the specified URL with the specified parameters. The
2817    parameters will be stored in hidden fields, and the form's only visible control will
2818    be a submit button with the specified caption.
2819    
2820    Note that we don't use B<CGI.pm> services here because they generate forms with extra characters
2821    and tags that we don't want to deal with.
2822    
2823    =over 4
2824    
2825    =item caption
2826    
2827    Caption to be put on the form button.
2828    
2829    =item url
2830    
2831    URL to be put in the form's action parameter.
2832    
2833    =item target
2834    
2835    Frame or target in which the form results should appear. If C<undef> is specified,
2836    the default target will be used.
2837    
2838    =item parms
2839    
2840    Hash containing the parameter names as keys and the parameter values as values.
2841    
2842    =back
2843    
2844    =cut
2845    
2846    sub Formlet {
2847        # Get the parameters.
2848        my ($caption, $url, $target, %parms) = @_;
2849        # Compute the target HTML.
2850        my $targetHtml = ($target ? " target=\"$target\"" : "");
2851        # Start the form.
2852        my $retVal = "<form method=\"POST\" action=\"$url\"$target>";
2853        # Add the parameters.
2854        for my $parm (keys %parms) {
2855            $retVal .= "<input type=\"hidden\" name=\"$parm\" value=\"$parms{$parm}\" />";
2856        }
2857        # Put in the button.
2858        $retVal .= "<input type=\"submit\" name=\"submit\" value=\"$caption\" class=\"button\" />";
2859        # Close the form.
2860        $retVal .= "</form>";
2861        # Return the result.
2862        return $retVal;
2863    }
2864    
2865    =head2 Virtual Methods
2866    
2867    =head3 Form
2868    
2869    C<< my $html = $shelp->Form(); >>
2870    
2871    Generate the HTML for a form to request a new search.
2872    
2873    =head3 Find
2874    
2875    C<< my $resultCount = $shelp->Find(); >>
2876    
2877    Conduct a search based on the current CGI query parameters. The search results will
2878    be written to the session cache file and the number of results will be
2879    returned. If the search parameters are invalid, a result count of C<undef> will be
2880    returned and a result message will be stored in this object describing the problem.
2881    
2882    =head3 Description
2883    
2884    C<< my $htmlText = $shelp->Description(); >>
2885    
2886    Return a description of this search. The description is used for the table of contents
2887    on the main search tools page. It may contain HTML, but it should be character-level,
2888    not block-level, since the description is going to appear in a list.
2889    
2890    =head3 SortKey
2891    
2892    C<< my $key = $shelp->SortKey($fdata); >>
2893    
2894    Return the sort key for the specified feature data. The default is to sort by feature name,
2895    floating NMPDR organisms to the top. If a full-text search is used, then the default
2896    sort is by relevance followed by feature name. This sort may be overridden by the
2897    search class to provide fancier functionality. This method is called by
2898    B<PutFeature>, so it is only used for feature searches. A non-feature search
2899    would presumably have its own sort logic.
2900    
2901    =over 4
2902    
2903    =item record
2904    
2905    The C<FeatureData> containing the current feature.
2906    
2907    =item RETURN
2908    
2909    Returns a key field that can be used to sort this row in among the results.
2910    
2911    =back
2912    
2913    =cut
2914    
2915    sub SortKey {
2916        # Get the parameters.
2917        my ($self, $fdata) = @_;
2918        # Get the feature ID from the record.
2919        my $fid = $fdata->FID();
2920        # Get the group from the feature ID.
2921        my $group = $self->FeatureGroup($fid);
2922        # Ask the feature query object to form the sort key.
2923        my $retVal = $fdata->SortKey($self, $group);
2924        # Return the result.
2925        return $retVal;
2926    }
2927    
2928    =head3 PrintLine
2929    
2930    C<< $shelp->PrintLine($message); >>
2931    
2932    Print a line of CGI output. This is used during the operation of the B<Find> method while
2933    searching, so the user sees progress in real-time.
2934    
2935    =over 4
2936    
2937    =item message
2938    
2939    HTML text to display.
2940    
2941    =back
2942    
2943    =cut
2944    
2945    sub PrintLine {
2946        # Get the parameters.
2947        my ($self, $message) = @_;
2948        # Send them to the output.
2949        print "$message\n";
2950    }
2951    
2952    
2953  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3