[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.3, Fri Sep 29 15:10:05 2006 UTC revision 1.22, Sat Dec 2 09:45:30 2006 UTC
# Line 113  Line 113 
113    
114  =item 4  =item 4
115    
116  In the C<SearchSkeleton.cgi> script, add a C<use> statement for your search tool  In the C<SearchSkeleton.cgi> script and add a C<use> statement for your search tool.
 and then put the class name in the C<@advancedClasses> list.  
117    
118  =back  =back
119    
# Line 177  Line 176 
176    
177  =back  =back
178    
179    If you are doing a feature search, you can also change the list of feature
180    columns displayed and their display order by overriding
181    L</DefaultFeatureColumns>.
182    
183  Finally, when generating the code for your controls, be sure to use any incoming  Finally, when generating the code for your controls, be sure to use any incoming
184  query parameters as default values so that the search request is persistent.  query parameters as default values so that the search request is persistent.
185    
# Line 214  Line 217 
217                      }                      }
218                  }                  }
219              }              }
         }  
220          # Close the session file.          # Close the session file.
221          $self->CloseSession();          $self->CloseSession();
222            }
223          # Return the result count.          # Return the result count.
224          return $retVal;          return $retVal;
225      }      }
226    
227  A Find method is of course much more complicated than generating a form, and there  A Find method is of course much more complicated than generating a form, and there
228  are variations on the above them. For example, you could eschew feature filtering  are variations on the above theme. For example, you could eschew feature filtering
229  entirely in favor of your own custom filtering, you could include extra columns  entirely in favor of your own custom filtering, you could include extra columns
230  in the output, or you could search for something that's not a feature at all. The  in the output, or you could search for something that's not a feature at all. The
231  above code is just a loose framework.  above code is just a loose framework.
# Line 237  Line 240 
240  by calling L</SetMessage>. If the parameters are valid, then the method must return  by calling L</SetMessage>. If the parameters are valid, then the method must return
241  the number of items found.  the number of items found.
242    
 =head2 Virtual Methods  
   
 =head3 Form  
   
 C<< my $html = $shelp->Form(); >>  
   
 Generate the HTML for a form to request a new search.  
   
 =head3 Find  
   
 C<< my $resultCount = $shelp->Find(); >>  
   
 Conduct a search based on the current CGI query parameters. The search results will  
 be written to the session cache file and the number of results will be  
 returned. If the search parameters are invalid, a result count of C<undef> will be  
 returned and a result message will be stored in this object describing the problem.  
   
 =head3 Description  
   
 C<< my $htmlText = $shelp->Description(); >>  
   
 Return a description of this search. The description is used for the table of contents  
 on the main search tools page. It may contain HTML, but it should be character-level,  
 not block-level, since the description is going to appear in a list.  
   
243  =cut  =cut
244    
245  # 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.
246  my $formCount = 0;  my $formCount = 0;
247    # This counter is used to generate unique DIV IDs.
248    my $divCount = 0;
249    
250  =head2 Public Methods  =head2 Public Methods
251    
# Line 277  Line 257 
257    
258  =over 4  =over 4
259    
260  =item query  =item cgi
261    
262  The CGI query object for the current script.  The CGI query object for the current script.
263    
# Line 287  Line 267 
267    
268  sub new {  sub new {
269      # Get the parameters.      # Get the parameters.
270      my ($class, $query) = @_;      my ($class, $cgi) = @_;
271      # Check for a session ID.      # Check for a session ID.
272      my $session_id = $query->param("SessionID");      my $session_id = $cgi->param("SessionID");
273      my $type = "old";      my $type = "old";
274      if (! $session_id) {      if (! $session_id) {
275          # Here we're starting a new session. We create the session ID and          # Here we're starting a new session. We create the session ID and
276          # store it in the query object.          # store it in the query object.
277          $session_id = NewSessionID();          $session_id = NewSessionID();
278          $type = "new";          $type = "new";
279          $query->param(-name => 'SessionID', -value => $session_id);          $cgi->param(-name => 'SessionID', -value => $session_id);
280      }      }
281      # Compute the subclass name.      # Compute the subclass name.
282      $class =~ /SH(.+)$/;      my $subClass;
283      my $subClass = $1;      if ($class =~ /SH(.+)$/) {
284            # Here we have a real search class.
285            $subClass = $1;
286        } else {
287            # Here we have a bare class. The bare class cannot search, but it can
288            # process search results.
289            $subClass = 'SearchHelper';
290        }
291      # Insure everybody knows we're in Sprout mode.      # Insure everybody knows we're in Sprout mode.
292      $query->param(-name => 'SPROUT', -value => 1);      $cgi->param(-name => 'SPROUT', -value => 1);
293      # Generate the form name.      # Generate the form name.
294      my $formName = "$class$formCount";      my $formName = "$class$formCount";
295      $formCount++;      $formCount++;
# Line 310  Line 297 
297      # 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
298      # class name and a placeholder for the Sprout object.      # class name and a placeholder for the Sprout object.
299      my $retVal = {      my $retVal = {
300                    query => $query,                    query => $cgi,
301                    type => $type,                    type => $type,
302                    class => $subClass,                    class => $subClass,
303                    sprout => undef,                    sprout => undef,
# Line 341  Line 328 
328      return $self->{query};      return $self->{query};
329  }  }
330    
331    
332    
333  =head3 DB  =head3 DB
334    
335  C<< my $sprout = $shelp->DB(); >>  C<< my $sprout = $shelp->DB(); >>
# Line 472  Line 461 
461      my ($self, $title) = @_;      my ($self, $title) = @_;
462      # Get the CGI object.      # Get the CGI object.
463      my $cgi = $self->Q();      my $cgi = $self->Q();
464      # Start the form.      # Start the form. Note we use the override option on the Class value, in
465        # case the Advanced button was used.
466      my $retVal = "<div class=\"search\">\n" .      my $retVal = "<div class=\"search\">\n" .
467                   $cgi->start_form(-method => 'POST',                   $cgi->start_form(-method => 'POST',
468                                    -action => $cgi->url(-relative => 1),                                    -action => $cgi->url(-relative => 1),
469                                    -name => $self->FormName()) .                                    -name => $self->FormName()) .
470                   $cgi->hidden(-name => 'Class',                   $cgi->hidden(-name => 'Class',
471                                -value => $self->{class}) .                                -value => $self->{class},
472                                  -override => 1) .
473                   $cgi->hidden(-name => 'SPROUT',                   $cgi->hidden(-name => 'SPROUT',
474                                -value => 1) .                                -value => 1) .
475                   $cgi->h3($title);                   $cgi->h3($title);
# Line 632  Line 623 
623    
624  =head3 PutFeature  =head3 PutFeature
625    
626  C<< $shelp->PutFeature($fquery); >>  C<< $shelp->PutFeature($fdata); >>
627    
628  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
629  searches, since the primary data item in the database is features.  searches, since the primary data item in the database is features.
# Line 643  Line 634 
634  the feature query object using the B<AddExtraColumns> method. For example, the following  the feature query object using the B<AddExtraColumns> method. For example, the following
635  code adds columns for essentiality and virulence.  code adds columns for essentiality and virulence.
636    
637      $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);      $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
638      $shelp->PutFeature($fq);      $shelp->PutFeature($fd);
639    
640  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
641  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 654  Line 645 
645      if (! $essentialFlag) {      if (! $essentialFlag) {
646          $essentialFlag = undef;          $essentialFlag = undef;
647      }      }
648      $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);      $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
649      $shelp->PutFeature($fq);      $shelp->PutFeature($fd);
650    
651  =over 4  =over 4
652    
653  =item fquery  =item fdata
654    
655  FeatureQuery object containing the current feature data.  B<FeatureData> object containing the current feature data.
656    
657  =back  =back
658    
# Line 669  Line 660 
660    
661  sub PutFeature {  sub PutFeature {
662      # Get the parameters.      # Get the parameters.
663      my ($self, $fq) = @_;      my ($self, $fd) = @_;
664      # Get the CGI query object.      # Get the CGI query object.
665      my $cgi = $self->Q();      my $cgi = $self->Q();
666      # Get the feature data.      # Get the feature data.
667      my $record = $fq->Feature();      my $record = $fd->Feature();
668      my $extraCols = $fq->ExtraCols();      my $extraCols = $fd->ExtraCols();
669      # Check for a first-call situation.      # Check for a first-call situation.
670      if (! defined $self->{cols}) {      if (! defined $self->{cols}) {
671          # Here we need to set up the column information. Start with the defaults.          Trace("Setting up the columns.") if T(3);
672          $self->{cols} = $self->DefaultFeatureColumns();          # Here we need to set up the column information. Start with the extras,
673          # Add the externals if they were requested.          # sorted by column name.
674          if ($cgi->param('ShowAliases')) {          my @colNames = ();
             push @{$self->{cols}}, 'alias';  
         }  
         # Append the extras, sorted by column name.  
675          for my $col (sort keys %{$extraCols}) {          for my $col (sort keys %{$extraCols}) {
676              push @{$self->{cols}}, "X=$col";              push @colNames, "X=$col";
677          }          }
678            # Add the default columns.
679            push @colNames, $self->DefaultFeatureColumns();
680            # Add any additional columns requested by the feature filter.
681            push @colNames, FeatureQuery::AdditionalColumns($self);
682            # Save the full list.
683            $self->{cols} = \@colNames;
684          # Write out the column headers. This also prepares the cache file to receive          # Write out the column headers. This also prepares the cache file to receive
685          # output.          # output.
686          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});
687      }      }
688      # Get the feature ID.      # Get the feature ID.
689      my ($fid) = $record->Value('Feature(id)');      my $fid = $fd->FID();
690      # Loop through the column headers, producing the desired data.      # Loop through the column headers, producing the desired data.
691      my @output = ();      my @output = ();
692      for my $colName (@{$self->{cols}}) {      for my $colName (@{$self->{cols}}) {
693          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
694      }      }
695      # 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
696      # top of the return list.      # top of the return list.
697      my $group = $self->FeatureGroup($fid);      my $key = $self->SortKey($fd);
     my $key = ($group ? "A$group" : "ZZ");  
698      # Write the feature data.      # Write the feature data.
699      $self->WriteColumnData($key, @output);      $self->WriteColumnData($key, @output);
700  }  }
# Line 782  Line 775 
775      # Check for an open session file.      # Check for an open session file.
776      if (defined $self->{fileHandle}) {      if (defined $self->{fileHandle}) {
777          # We found one, so close it.          # We found one, so close it.
778            Trace("Closing session file.") if T(2);
779          close $self->{fileHandle};          close $self->{fileHandle};
780      }      }
781  }  }
# Line 799  Line 793 
793      my $retVal;      my $retVal;
794      # Get a digest encoder.      # Get a digest encoder.
795      my $md5 = Digest::MD5->new();      my $md5 = Digest::MD5->new();
796      # 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
797      if (open(R, "/dev/urandom")) {      # actually two numbers, and we get them both because we're in list
798          my $b;      # context.
799          read(R, $b, 1024);      $md5->add($$, $ENV{REMOTE_ADDR}, $ENV{REMOTE_PORT}, gettimeofday());
800          $md5->add($b);      # Hash up all this identifying data.
801      }      $retVal = $md5->hexdigest();
802      # 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.  
803      return $retVal;      return $retVal;
804  }  }
805    
# Line 855  Line 843 
843                                                      ['Genome(genus)', 'Genome(species)',                                                      ['Genome(genus)', 'Genome(species)',
844                                                       'Genome(unique-characterization)',                                                       'Genome(unique-characterization)',
845                                                       'Genome(primary-group)']);                                                       'Genome(primary-group)']);
846          # Null out the supporting group.          # Format and cache the name and display group.
847          $group = "" if ($group eq $FIG_Config::otherGroup);          ($orgName, $group) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
848          # 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];  
849      }      }
850      # Return the result.      # Return the result.
851      return ($orgName, $group);      return ($orgName, $group);
# Line 970  Line 947 
947      } else {      } else {
948          # Here we can get its genome data.          # Here we can get its genome data.
949          $retVal = $self->Organism($genomeID);          $retVal = $self->Organism($genomeID);
950          # Append the type and number.          # Append the FIG ID.
951          $retVal .= " [$type $num]";          $retVal .= " [$fid]";
952      }      }
953      # Return the result.      # Return the result.
954      return $retVal;      return $retVal;
# Line 979  Line 956 
956    
957  =head3 ComputeFASTA  =head3 ComputeFASTA
958    
959  C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >>  C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence); >>
960    
961  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.  
962    
963  =over 4  =over 4
964    
 =item incomingType  
   
 C<dna> if this is a DNA sequence, C<prot> if this is a protein sequence.  
   
965  =item desiredType  =item desiredType
966    
967  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.  
968    
969  =item sequence  =item sequence
970    
# Line 1016  Line 986 
986    
987  sub ComputeFASTA {  sub ComputeFASTA {
988      # Get the parameters.      # Get the parameters.
989      my ($self, $incomingType, $desiredType, $sequence) = @_;      my ($self, $desiredType, $sequence) = @_;
990      # Declare the return variable. If an error occurs, it will remain undefined.      # Declare the return variable. If an error occurs, it will remain undefined.
991      my $retVal;      my $retVal;
992        # This variable will be cleared if an error is detected.
993        my $okFlag = 1;
994      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
995      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
996        Trace("FASTA desired type is $desiredType.") if T(4);
997      # Check for a feature specification.      # Check for a feature specification.
998      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
999          # 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
1000          # it.          # it.
1001          my $fid = $1;          my $fid = $1;
1002            Trace("Feature ID for fasta is $fid.") if T(3);
1003          my $sprout = $self->DB();          my $sprout = $self->DB();
1004          # 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
1005          # 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
1006          # exist.          # exist.
1007          my ($figID) = $sprout->FeaturesByAlias($fid);          my ($figID) = $sprout->FeaturesByAlias($fid);
1008          if (! $figID) {          if (! $figID) {
1009              $self->SetMessage("No feature found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
1010                $okFlag = 0;
1011          } else {          } else {
1012              # Set the FASTA label.              # Set the FASTA label.
1013              my $fastaLabel = $fid;              my $fastaLabel = $fid;
1014              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
1015              if ($desiredType =~ /prot/i) {              if ($desiredType eq 'prot') {
1016                  # We want protein, so get the translation.                  # We want protein, so get the translation.
1017                  $fastaData = $sprout->FeatureTranslation($figID);                  $fastaData = $sprout->FeatureTranslation($figID);
1018                    Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
1019              } else {              } else {
1020                  # 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.
1021                  my @locList = $sprout->FeatureLocation($figID);                  my @locList = $sprout->FeatureLocation($figID);
1022                  $fastaData = $sprout->DNASeq(\@locList);                  $fastaData = $sprout->DNASeq(\@locList);
1023                    Trace(length $fastaData . " characters returned for DNA of $fastaLabel.") if T(3);
1024              }              }
1025          }          }
     } elsif ($incomingType =~ /prot/ && $desiredType =~ /dna/) {  
         # Here we're being asked to do an impossible conversion.  
         $self->SetMessage("Cannot convert a protein sequence to DNA.");  
1026      } else {      } else {
1027            Trace("Analyzing FASTA sequence.") if T(4);
1028          # 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.
1029          if ($sequence =~ /^>\s*(\S.*)\s*\n(.+)$/) {          if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) {
1030                Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4);
1031              # Here we have a label, so we split it from the data.              # Here we have a label, so we split it from the data.
1032              $fastaLabel = $1;              $fastaLabel = $1;
1033              $fastaData = $2;              $fastaData = $2;
1034          } else {          } else {
1035                Trace("No label found in match to sequence:\n$sequence") if T(4);
1036              # 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
1037              # as data.              # as data.
1038              $fastaLabel = "User-specified $incomingType sequence";              $fastaLabel = "User-specified $desiredType sequence";
1039              $fastaData = $sequence;              $fastaData = $sequence;
1040          }          }
1041          # The next step is to clean the junk out of the sequence.          # The next step is to clean the junk out of the sequence.
1042          $fastaData =~ s/\n//g;          $fastaData =~ s/\n//g;
1043          $fastaData =~ s/\s+//g;          $fastaData =~ s/\s+//g;
1044          # 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.
1045          # we've already prevented a conversion from protein to DNA.          if ($desiredType eq 'dna' && $fastaData =~ /[^agct]/i) {
1046          if ($incomingType ne $desiredType) {              $self->SetMessage("Invaid characters detected. Is the input really a DNA sequence?");
1047              $fastaData = Sprout::Protein($fastaData);              $okFlag = 0;
1048          }          }
1049      }      }
1050      # At this point, either "$fastaLabel" and "$fastaData" have values or an error is      Trace("FASTA data sequence: $fastaData") if T(4);
1051      # in progress.      # Only proceed if no error was detected.
1052      if (defined $fastaLabel) {      if ($okFlag) {
1053          # 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
1054          # grep-split trick. The split, because of the presence of the parentheses,          # grep-split trick. The split, because of the presence of the parentheses,
1055          # includes the matched delimiters in the output list. The grep strips out          # includes the matched delimiters in the output list. The grep strips out
1056          # the empty list items that appear between the so-called delimiters, since          # the empty list items that appear between the so-called delimiters, since
1057          # the delimiters are what we want.          # the delimiters are what we want.
1058          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
1059          my $retVal = join("\n", ">$fastaLabel", @chunks, "");          $retVal = join("\n", ">$fastaLabel", @chunks, "");
1060      }      }
1061      # Return the result.      # Return the result.
1062      return $retVal;      return $retVal;
1063  }  }
1064    
1065    =head3 SubsystemTree
1066    
1067    C<< my $tree = SearchHelper::SubsystemTree($sprout, %options); >>
1068    
1069    This method creates a subsystem selection tree suitable for passing to
1070    L</SelectionTree>. Each leaf node in the tree will have a link to the
1071    subsystem display page. In addition, each node can have a radio button. The
1072    radio button alue is either C<classification=>I<string>, where I<string> is
1073    a classification string, or C<id=>I<string>, where I<string> is a subsystem ID.
1074    Thus, it can either be used to filter by a group of related subsystems or a
1075    single subsystem.
1076    
1077    =over 4
1078    
1079    =item sprout
1080    
1081    Sprout database object used to get the list of subsystems.
1082    
1083    =item options
1084    
1085    Hash containing options for building the tree.
1086    
1087    =item RETURN
1088    
1089    Returns a reference to a tree list suitable for passing to L</SelectionTree>.
1090    
1091    =back
1092    
1093    The supported options are as follows.
1094    
1095    =over 4
1096    
1097    =item radio
1098    
1099    TRUE if the tree should be configured for radio buttons. The default is FALSE.
1100    
1101    =item links
1102    
1103    TRUE if the tree should be configured for links. The default is TRUE.
1104    
1105    =back
1106    
1107    =cut
1108    
1109    sub SubsystemTree {
1110        # Get the parameters.
1111        my ($sprout, %options) = @_;
1112        # Process the options.
1113        my $optionThing = Tracer::GetOptions({ radio => 0, links => 1 }, \%options);
1114        # Read in the subsystems.
1115        my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1116                                   ['Subsystem(classification)', 'Subsystem(id)']);
1117        # Declare the return variable.
1118        my @retVal = ();
1119        # Each element in @subs represents a leaf node, so as we loop through it we will be
1120        # producing one leaf node at a time. The leaf node is represented as a 2-tuple. The
1121        # first element is a semi-colon-delimited list of the classifications for the
1122        # subsystem. There will be a stack of currently-active classifications, which we will
1123        # compare to the incoming classifications from the end backward. A new classification
1124        # requires starting a new branch. A different classification requires closing an old
1125        # branch and starting a new one. Each classification in the stack will also contain
1126        # that classification's current branch. We'll add a fake classification at the
1127        # beginning that we can use to represent the tree as a whole.
1128        my $rootName = '<root>';
1129        # Create the classification stack. Note the stack is a pair of parallel lists,
1130        # one containing names and the other containing content.
1131        my @stackNames = ($rootName);
1132        my @stackContents = (\@retVal);
1133        # Add a null entry at the end of the subsystem list to force an unrolling.
1134        push @subs, ['', undef];
1135        # Loop through the subsystems.
1136        for my $sub (@subs) {
1137            # Pull out the classification list and the subsystem ID.
1138            my ($classString, $id) = @{$sub};
1139            Trace("Processing class \"$classString\" and subsystem $id.") if T(4);
1140            # Convert the classification string to a list with the root classification in
1141            # the front.
1142            my @classList = ($rootName, split($FIG_Config::splitter, $classString));
1143            # Find the leftmost point at which the class list differs from the stack.
1144            my $matchPoint = 0;
1145            while ($matchPoint <= $#stackNames && $matchPoint <= $#classList &&
1146                   $stackNames[$matchPoint] eq $classList[$matchPoint]) {
1147                $matchPoint++;
1148            }
1149            Trace("Match point is $matchPoint. Stack length is " . scalar(@stackNames) .
1150                  ". Class List length is " . scalar(@classList) . ".") if T(4);
1151            # Unroll the stack to the matchpoint.
1152            while ($#stackNames >= $matchPoint) {
1153                my $popped = pop @stackNames;
1154                pop @stackContents;
1155                Trace("\"$popped\" popped from stack.") if T(4);
1156            }
1157            # Start branches for any new classifications.
1158            while ($#stackNames < $#classList) {
1159                # The branch for a new classification contains its radio button
1160                # data and then a list of children. So, at this point, if radio buttons
1161                # are desired, we put them into the content.
1162                my $newLevel = scalar(@stackNames);
1163                my @newClassContent = ();
1164                if ($optionThing->{radio}) {
1165                    my $newClassString = join($FIG_Config::splitter, @classList[1..$newLevel]);
1166                    push @newClassContent, { value => "classification=$newClassString%" };
1167                }
1168                # The new classification node is appended to its parent's content
1169                # and then pushed onto the stack. First, we need the node name.
1170                my $nodeName = $classList[$newLevel];
1171                # Add the classification to its parent. This makes it part of the
1172                # tree we'll be returning to the user.
1173                push @{$stackContents[$#stackNames]}, $nodeName, \@newClassContent;
1174                # Push the classification onto the stack.
1175                push @stackContents, \@newClassContent;
1176                push @stackNames, $nodeName;
1177                Trace("\"$nodeName\" pushed onto stack.") if T(4);
1178            }
1179            # Now the stack contains all our parent branches. We add the subsystem to
1180            # the branch at the top of the stack, but only if it's NOT the dummy node.
1181            if (defined $id) {
1182                # Compute the node name from the ID.
1183                my $nodeName = $id;
1184                $nodeName =~ s/_/ /g;
1185                # Create the node's leaf hash. This depends on the value of the radio
1186                # and link options.
1187                my $nodeContent = {};
1188                if ($optionThing->{links}) {
1189                    # Compute the link value.
1190                    my $linkable = uri_escape($id);
1191                    $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;SPROUT=1";
1192                }
1193                if ($optionThing->{radio}) {
1194                    # Compute the radio value.
1195                    $nodeContent->{value} = "id=$id";
1196                }
1197                # Push the node into its parent branch.
1198                Trace("\"$nodeName\" added to node list.") if T(4);
1199                push @{$stackContents[$#stackNames]}, $nodeName, $nodeContent;
1200            }
1201        }
1202        # Return the result.
1203        return \@retVal;
1204    }
1205    
1206    
1207  =head3 NmpdrGenomeMenu  =head3 NmpdrGenomeMenu
1208    
1209  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>
# Line 1114  Line 1233 
1233  Number of rows to display. If omitted, the default is 1 for a single-select list  Number of rows to display. If omitted, the default is 1 for a single-select list
1234  and 10 for a multi-select list.  and 10 for a multi-select list.
1235    
1236    =item crossMenu (optional)
1237    
1238    If specified, is presumed to be the name of another genome menu whose contents
1239    are to be mutually exclusive with the contents of this menu. As a result, instead
1240    of the standard onChange event, the onChange event will deselect any entries in
1241    the other menu.
1242    
1243  =item RETURN  =item RETURN
1244    
1245  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 1124  Line 1250 
1250    
1251  sub NmpdrGenomeMenu {  sub NmpdrGenomeMenu {
1252      # Get the parameters.      # Get the parameters.
1253      my ($self, $menuName, $multiple, $selected, $rows) = @_;      my ($self, $menuName, $multiple, $selected, $rows, $cross) = @_;
1254      # Get the Sprout and CGI objects.      # Get the Sprout and CGI objects.
1255      my $sprout = $self->DB();      my $sprout = $self->DB();
1256      my $cgi = $self->Q();      my $cgi = $self->Q();
# Line 1158  Line 1284 
1284          for my $genome (@genomeList) {          for my $genome (@genomeList) {
1285              # Get the genome data.              # Get the genome data.
1286              my ($group, $genomeID, $genus, $species, $strain) = @{$genome};              my ($group, $genomeID, $genus, $species, $strain) = @{$genome};
1287              # Form the genome name.              # Compute and cache its name and display group.
1288              my $name = "$genus $species";              my ($name, $displayGroup) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1289              if ($strain) {                                                                  $strain);
1290                  $name .= " $strain";              # Push the genome into the group's list. Note that we use the real group
1291              }              # name here, not the display group name.
             # Push the genome into the group's list.  
1292              push @{$gHash{$group}}, [$genomeID, $name];              push @{$gHash{$group}}, [$genomeID, $name];
1293          }          }
1294          # Save the genome list for future use.          # Save the genome list for future use.
# Line 1180  Line 1305 
1305      if (defined $selected) {      if (defined $selected) {
1306          %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};          %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};
1307      }      }
1308      # Now it gets complicated. We need a way to mark all the NMPDR genomes.      # Now it gets complicated. We need a way to mark all the NMPDR genomes. We take advantage
1309        # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes
1310        # and use that to make the selections.
1311        my $nmpdrCount = 0;
1312      # Create the type counters.      # Create the type counters.
1313      my $groupCount = 1;      my $groupCount = 1;
1314      # Compute the ID for the status display.      # Compute the ID for the status display.
# Line 1189  Line 1317 
1317      my $showSelect = "showSelected($menuName, '$divID', 1000);";      my $showSelect = "showSelected($menuName, '$divID', 1000);";
1318      # If multiple selection is supported, create an onChange event.      # If multiple selection is supported, create an onChange event.
1319      my $onChange = "";      my $onChange = "";
1320      if ($multiple) {      if ($cross) {
1321            # Here we have a paired menu. Selecting something in our menu unselects it in the
1322            # other and redisplays the status of both.
1323            $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";
1324        } elsif ($multiple) {
1325            # This is an unpaired menu, so all we do is redisplay our status.
1326          $onChange = " onChange=\"$showSelect\"";          $onChange = " onChange=\"$showSelect\"";
1327      }      }
1328      # Create the SELECT tag and stuff it into the output array.      # Create the SELECT tag and stuff it into the output array.
1329      my $select = "<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">";      my @lines = ("<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">");
     my @lines = ($select);  
1330      # Loop through the groups.      # Loop through the groups.
1331      for my $group (@groups) {      for my $group (@groups) {
1332          # Create the option group tag.          # Create the option group tag.
1333          my $tag = "<OPTGROUP label=\"$group\">";          my $tag = "<OPTGROUP label=\"$group\">";
1334          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, so we can't use it.  
         my $label = ($group eq $FIG_Config::otherGroup ? "other" : "nmpdr");  
1335          # Get the genomes in the group.          # Get the genomes in the group.
1336          for my $genome (@{$groupHash->{$group}}) {          for my $genome (@{$groupHash->{$group}}) {
1337                # Count this organism if it's NMPDR.
1338                if ($group ne $FIG_Config::otherGroup) {
1339                    $nmpdrCount++;
1340                }
1341                # Get the organism ID and name.
1342              my ($genomeID, $name) = @{$genome};              my ($genomeID, $name) = @{$genome};
1343              # See if it's selected.              # See if it's selected.
1344              my $select = ($selectedHash{$genomeID} ? " selected" : "");              my $select = ($selectedHash{$genomeID} ? " selected" : "");
1345              # Generate the option tag.              # Generate the option tag.
1346              my $optionTag = "<OPTION value=\"$genomeID\" label=\"$label\"$select>$name <em>($genomeID)</em></OPTION>";              my $optionTag = "<OPTION value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";
1347              push @lines, "    $optionTag";              push @lines, "    $optionTag";
1348          }          }
1349          # Close the option group.          # Close the option group.
# Line 1222  Line 1353 
1353      push @lines, "</SELECT>";      push @lines, "</SELECT>";
1354      # Check for multiple selection.      # Check for multiple selection.
1355      if ($multiple) {      if ($multiple) {
1356          # Since multi-select is on, we set up some buttons to set and clear selections.          # Multi-select is on, so we need to add some selection helpers. First is
1357          push @lines, "<br />";          # the search box. This allows the user to type text and have all genomes containing
         push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";  
         push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";  
         push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\"  value=\"Select NMPDR\" onClick=\"selectSome($menuName, 'nmpdr'); $showSelect\" />";  
         push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, 'other'); $showSelect\" />";  
         # Now add the search box. This allows the user to type text and have all genomes containing  
1358          # the text selected automatically.          # the text selected automatically.
1359          my $searchThingName = "${menuName}_SearchThing";          my $searchThingName = "${menuName}_SearchThing";
1360          push @lines, "<br>Select genomes containing <INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />&nbsp;" .          push @lines, "<br />" .
1361                       "<INPUT type=\"button\" name=\"Select\" class=\"button\" value=\"Search\" onClick=\"selectViaSearch($menuName, $searchThingName); $showSelect\" />";                       "<INPUT type=\"button\" name=\"Search\" class=\"button\" value=\"Select genomes containing\" onClick=\"selectViaSearch($menuName, $searchThingName); $showSelect\" />&nbsp;" .
1362                         "<INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />";
1363            # Next are the buttons to set and clear selections.
1364            push @lines, "<br />";
1365            push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";
1366            push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";
1367            push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\"  value=\"Select NMPDR\" onClick=\"selectSome($menuName, $nmpdrCount, true); $showSelect\" />";
1368            push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, $nmpdrCount, false); $showSelect\" />";
1369          # Add the status display, too.          # Add the status display, too.
1370          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";
1371          # 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 1351  Line 1484 
1484    
1485  =head3 SubmitRow  =head3 SubmitRow
1486    
1487  C<< my $htmlText = $shelp->SubmitRow(); >>  C<< my $htmlText = $shelp->SubmitRow($caption); >>
1488    
1489  Returns the HTML text for the row containing the page size control  Returns the HTML text for the row containing the page size control
1490  and the submit button. All searches should have this row somewhere  and the submit button. All searches should have this row somewhere
1491  near the top of the form.  near the top of the form.
1492    
1493    =over 4
1494    
1495    =item caption (optional)
1496    
1497    Caption to be put on the search button. The default is C<Go>.
1498    
1499    =item RETURN
1500    
1501    Returns a table row containing the controls for submitting the search
1502    and tuning the results.
1503    
1504    =back
1505    
1506  =cut  =cut
1507    
1508  sub SubmitRow {  sub SubmitRow {
1509      # Get the parameters.      # Get the parameters.
1510      my ($self) = @_;      my ($self, $caption) = @_;
1511      my $cgi = $self->Q();      my $cgi = $self->Q();
1512        # Compute the button caption.
1513        my $realCaption = (defined $caption ? $caption : 'Go');
1514      # Get the current page size.      # Get the current page size.
1515      my $pageSize = $cgi->param('PageSize');      my $pageSize = $cgi->param('PageSize');
1516      # Get the incoming external-link flag.      # Get the incoming external-link flag.
# Line 1370  Line 1518 
1518      # Create the row.      # Create the row.
1519      my $retVal = $cgi->Tr($cgi->td("Results/Page"),      my $retVal = $cgi->Tr($cgi->td("Results/Page"),
1520                            $cgi->td($cgi->popup_menu(-name => 'PageSize',                            $cgi->td($cgi->popup_menu(-name => 'PageSize',
1521                                                      -values => [10, 25, 45, 100, 1000],                                                      -values => [10, 25, 50, 100, 1000],
1522                                                      -default => $pageSize) . " " .                                                      -default => $pageSize) . " " .
                                    $cgi->checkbox(-name => 'ShowAliases',  
                                                   -value => 1,  
                                                   -label => 'Show Alias Links',  
                                                   -default => $aliases),  
1523                                     $cgi->checkbox(-name => 'ShowURL',                                     $cgi->checkbox(-name => 'ShowURL',
1524                                                    -value => 1,                                                    -value => 1,
1525                                                    -label => 'Show URL')),                                                    -label => 'Show URL',
1526                                                      -checked => 1)),
1527                            $cgi->td($cgi->submit(-class => 'goButton',                            $cgi->td($cgi->submit(-class => 'goButton',
1528                                                  -name => 'Search',                                                  -name => 'Search',
1529                                                  -value => 'Go')));                                                  -value => $realCaption)));
1530      # Return the result.      # Return the result.
1531      return $retVal;      return $retVal;
1532  }  }
# Line 1390  Line 1535 
1535    
1536  C<< my $htmlText = $shelp->FeatureFilterRows(); >>  C<< my $htmlText = $shelp->FeatureFilterRows(); >>
1537    
1538  This method creates table rows that can be used to filter features. There are  This method creates table rows that can be used to filter features. The form
1539  two rows returned, and the values can be used to select features by genome  values can be used to select features by genome using the B<FeatureQuery>
1540  using the B<FeatureQuery> object.  object.
1541    
1542  =cut  =cut
1543    
# Line 1442  Line 1587 
1587          # Get the feature location string.          # Get the feature location string.
1588          my $loc = $sprout->FeatureLocation($feat);          my $loc = $sprout->FeatureLocation($feat);
1589          # Compute the contig, start, and stop points.          # Compute the contig, start, and stop points.
1590          my($start, $stop, $contig) = BasicLocation::Parse($loc);          my($contig, $start, $stop) = BasicLocation::Parse($loc);
1591            Trace("Start and stop are ($start,$stop) on contig $contig.") if T(3);
1592          # 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
1593          # big and that we get some surrounding stuff.          # big and that we get some surrounding stuff.
1594          my $mid = int(($start + $stop) / 2);          my $mid = int(($start + $stop) / 2);
# Line 1472  Line 1618 
1618          }          }
1619          my $seg_id = $contig;          my $seg_id = $contig;
1620          $seg_id =~ s/:/--/g;          $seg_id =~ s/:/--/g;
1621            Trace("Show limits are ($show_start,$show_stop) in genome $genomeID with ref $seg_id.") if T(3);
1622          # Assemble all the pieces.          # Assemble all the pieces.
1623          $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";
1624      }      }
1625      # Return the result.      # Return the result.
1626      return $retVal;      return $retVal;
# Line 1566  Line 1713 
1713    
1714  =head3 ComputeSearchURL  =head3 ComputeSearchURL
1715    
1716  C<< my $url = $shelp->ComputeSearchURL(); >>  C<< my $url = $shelp->ComputeSearchURL(%overrides); >>
1717    
1718  Compute the GET-style URL for the current search. In order for this to work, there  Compute the GET-style URL for the current search. In order for this to work, there
1719  must be a copy of the search form on the current page. This will always be the  must be a copy of the search form on the current page. This will always be the
# Line 1576  Line 1723 
1723  main complication is that if the user specified all genomes, we'll want to  main complication is that if the user specified all genomes, we'll want to
1724  remove the parameter entirely from a get-style URL.  remove the parameter entirely from a get-style URL.
1725    
1726    =over 4
1727    
1728    =item overrides
1729    
1730    Hash containing override values for the parameters, where the parameter name is
1731    the key and the parameter value is the override value. If the override value is
1732    C<undef>, the parameter will be deleted from the result.
1733    
1734    =item RETURN
1735    
1736    Returns a GET-style URL for invoking the search with the specified overrides.
1737    
1738    =back
1739    
1740  =cut  =cut
1741    
1742  sub ComputeSearchURL {  sub ComputeSearchURL {
1743      # Get the parameters.      # Get the parameters.
1744      my ($self) = @_;      my ($self, %overrides) = @_;
1745      # Get the database and CGI query object.      # Get the database and CGI query object.
1746      my $cgi = $self->Q();      my $cgi = $self->Q();
1747      my $sprout = $self->DB();      my $sprout = $self->DB();
# Line 1607  Line 1768 
1768          # a singleton list, but that's okay.          # a singleton list, but that's okay.
1769          my @values = split (/\0/, $parms{$parmKey});          my @values = split (/\0/, $parms{$parmKey});
1770          # Check for special cases.          # Check for special cases.
1771          if ($parmKey eq 'featureTypes') {          if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF ShowURL)) {
             # Here we need to see if the user wants all the feature types. If he  
             # does, we erase all the values so that the parameter is not output.  
             my %valueCheck = map { $_ => 1 } @values;  
             my @list = FeatureQuery::AllFeatureTypes();  
             my $okFlag = 1;  
             for (my $i = 0; $okFlag && $i <= $#list; $i++) {  
                 if (! $valueCheck{$list[$i]}) {  
                     $okFlag = 0;  
                 }  
             }  
             if ($okFlag) {  
                 @values = ();  
             }  
         } elsif (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF ShowURL)) {  
1772              # These are bookkeeping parameters we don't need to start a search.              # These are bookkeeping parameters we don't need to start a search.
1773              @values = ();              @values = ();
1774          } elsif ($parmKey =~ /_SearchThing$/) {          } elsif ($parmKey =~ /_SearchThing$/) {
# Line 1635  Line 1782 
1782              if ($allFlag) {              if ($allFlag) {
1783                  @values = ();                  @values = ();
1784              }              }
1785            } elsif (exists $overrides{$parmKey}) {
1786                # Here the value is being overridden, so we skip it for now.
1787                @values = ();
1788          }          }
1789          # If we still have values, create the URL parameters.          # If we still have values, create the URL parameters.
1790          if (@values) {          if (@values) {
1791              push @urlList, map { "$parmKey=" . uri_escape($_) } @values;              push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1792          }          }
1793      }      }
1794        # Now do the overrides.
1795        for my $overKey (keys %overrides) {
1796            # Only use this override if it's not a delete marker.
1797            if (defined $overrides{$overKey}) {
1798                push @urlList, "$overKey=" . uri_escape($overrides{$overKey});
1799            }
1800        }
1801      # Add the parameters to the URL.      # Add the parameters to the URL.
1802      $retVal .= "?" . join(";", @urlList);      $retVal .= "?" . join(";", @urlList);
1803      # Return the result.      # Return the result.
# Line 1683  Line 1840 
1840      return $retVal;      return $retVal;
1841  }  }
1842    
1843    =head3 AdvancedClassList
1844    
1845    C<< my @classes = SearchHelper::AdvancedClassList(); >>
1846    
1847    Return a list of advanced class names. This list is used to generate the directory
1848    of available searches on the search page.
1849    
1850    We use the %INC variable to accomplish this.
1851    
1852    =cut
1853    
1854    sub AdvancedClassList {
1855        my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;
1856        return @retVal;
1857    }
1858    
1859    =head3 SelectionTree
1860    
1861    C<< my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options); >>
1862    
1863    Display a selection tree.
1864    
1865    This method creates the HTML for a tree selection control. The tree is implemented as a set of
1866    nested HTML unordered lists. Each selectable element of the tree will contain a radio button. In
1867    addition, some of the tree nodes can contain hyperlinks.
1868    
1869    The tree itself is passed in as a multi-level list containing node names followed by
1870    contents. Each content element is a reference to a similar list. The first element of
1871    each list may be a hash reference. If so, it should contain one or both of the following
1872    keys.
1873    
1874    =over 4
1875    
1876    =item link
1877    
1878    The navigation URL to be popped up if the user clicks on the node name.
1879    
1880    =item value
1881    
1882    The form value to be returned if the user selects the tree node.
1883    
1884    =back
1885    
1886    The presence of a C<link> key indicates the node name will be hyperlinked. The presence of
1887    a C<value> key indicates the node name will have a radio button. If a node has no children,
1888    you may pass it a hash reference instead of a list reference.
1889    
1890    The following example shows the hash for a three-level tree with links on the second level and
1891    radio buttons on the third.
1892    
1893        [   Objects => [
1894                Entities => [
1895                    {link => "../docs/WhatIsAnEntity.html"},
1896                    Genome => {value => 'GenomeData'},
1897                    Feature => {value => 'FeatureData'},
1898                    Contig => {value => 'ContigData'},
1899                ],
1900                Relationships => [
1901                    {link => "../docs/WhatIsARelationShip.html"},
1902                    HasFeature => {value => 'GenomeToFeature'},
1903                    IsOnContig => {value => 'FeatureToContig'},
1904                ]
1905            ]
1906        ]
1907    
1908    Note how each leaf of the tree has a hash reference for its value, while the branch nodes
1909    all have list references.
1910    
1911    This next example shows how to set up a taxonomy selection field. The value returned
1912    by the tree control will be the taxonomy string for the selected node ready for use
1913    in a LIKE-style SQL filter. Only the single branch ending in campylobacter is shown for
1914    reasons of space.
1915    
1916        [   All => [
1917                {value => "%"},
1918                Bacteria => [
1919                    {value => "Bacteria%"},
1920                    Proteobacteria => [
1921                        {value => "Bacteria; Proteobacteria%"},
1922                        Epsilonproteobacteria => [
1923                            {value => "Bacteria; Proteobacteria;Epsilonproteobacteria%"},
1924                            Campylobacterales => [
1925                                {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales%"},
1926                                Campylobacteraceae =>
1927                                    {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales; Campylobacteraceae%"},
1928                                ...
1929                            ]
1930                            ...
1931                        ]
1932                        ...
1933                    ]
1934                    ...
1935                ]
1936                ...
1937            ]
1938        ]
1939    
1940    
1941    This method of tree storage allows the caller to control the order in which the tree nodes
1942    are displayed and to completely control value selection and use of hyperlinks. It is, however
1943    a bit complicated. Eventually, tree-building classes will be provided to simplify things.
1944    
1945    The parameters to this method are as follows.
1946    
1947    =over 4
1948    
1949    =item cgi
1950    
1951    CGI object used to generate the HTML.
1952    
1953    =item tree
1954    
1955    Reference to a hash describing a tree. See the description above.
1956    
1957    =item options
1958    
1959    Hash containing options for the tree display.
1960    
1961    =back
1962    
1963    The allowable options are as follows
1964    
1965    =over 4
1966    
1967    =item nodeImageClosed
1968    
1969    URL of the image to display next to the tree nodes when they are collapsed. Clicking
1970    on the image will expand a section of the tree. The default is C<../FIG/Html/plus.gif>.
1971    
1972    =item nodeImageOpen
1973    
1974    URL of the image to display next to the tree nodes when they are expanded. Clicking
1975    on the image will collapse a section of the tree. The default is C<../FIG/Html/minus.gif>.
1976    
1977    =item style
1978    
1979    Style to use for the tree. The default is C<tree>. Because the tree style is implemented
1980    as nested lists, the key components of this style are the definitions for the C<ul> and
1981    C<li> tags. The default style file contains the following definitions.
1982    
1983        .tree ul {
1984           margin-left: 0; padding-left: 22px
1985        }
1986        .tree li {
1987            list-style-type: none;
1988        }
1989    
1990    The default image is 22 pixels wide, so in the above scheme each tree level is indented from its
1991    parent by the width of the node image. This use of styles limits the things we can do in formatting
1992    the tree, but it has the advantage of vastly simplifying the tree creation.
1993    
1994    =item name
1995    
1996    Field name to give to the radio buttons in the tree. The default is C<selection>.
1997    
1998    =item target
1999    
2000    Frame target for links. The default is C<_self>.
2001    
2002    =item selected
2003    
2004    If specified, the value of the radio button to be pre-selected.
2005    
2006    =back
2007    
2008    =cut
2009    
2010    sub SelectionTree {
2011        # Get the parameters.
2012        my ($cgi, $tree, %options) = @_;
2013        # Get the options.
2014        my $optionThing = Tracer::GetOptions({ name => 'selection',
2015                                               nodeImageClosed => '../FIG/Html/plus.gif',
2016                                               nodeImageOpen => '../FIG/Html/minus.gif',
2017                                               style => 'tree',
2018                                               target => '_self',
2019                                               selected => undef},
2020                                             \%options);
2021        # Declare the return variable. We'll do the standard thing with creating a list
2022        # of HTML lines and rolling them together at the end.
2023        my @retVal = ();
2024        # Only proceed if the tree is present.
2025        if (defined($tree)) {
2026            # Validate the tree.
2027            if (ref $tree ne 'ARRAY') {
2028                Confess("Selection tree is not a list reference.");
2029            } elsif (scalar @{$tree} == 0) {
2030                # The tree is empty, so we do nothing.
2031            } elsif ($tree->[0] eq 'HASH') {
2032                Confess("Hash reference found at start of selection tree. The tree as a whole cannot have attributes, only tree nodes.");
2033            } else {
2034                # Here we have a real tree. Apply the tree style.
2035                push @retVal, $cgi->start_div({ class => $optionThing->{style} });
2036                # Give us a DIV ID.
2037                my $divID = GetDivID($optionThing->{name});
2038                # Show the tree.
2039                push @retVal, ShowBranch($cgi, "(root)", $divID, $tree, $optionThing, 'block');
2040                # Close the DIV block.
2041                push @retVal, $cgi->end_div();
2042            }
2043        }
2044        # Return the result.
2045        return join("\n", @retVal, "");
2046    }
2047    
2048    =head3 ShowBranch
2049    
2050    C<< my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType); >>
2051    
2052    This is a recursive method that displays a branch of the tree.
2053    
2054    =over 4
2055    
2056    =item cgi
2057    
2058    CGI object used to format HTML.
2059    
2060    =item label
2061    
2062    Label of this tree branch. It is only used in error messages.
2063    
2064    =item id
2065    
2066    ID to be given to this tree branch. The ID is used in the code that expands and collapses
2067    tree nodes.
2068    
2069    =item branch
2070    
2071    Reference to a list containing the content of the tree branch. The list contains an optional
2072    hash reference that is ignored and the list of children, each child represented by a name
2073    and then its contents. The contents could by a hash reference (indicating the attributes
2074    of a leaf node), or another tree branch.
2075    
2076    =item options
2077    
2078    Options from the original call to L</SelectionTree>.
2079    
2080    =item displayType
2081    
2082    C<block> if the contents of this list are to be displayed, C<none> if they are to be
2083    hidden.
2084    
2085    =item RETURN
2086    
2087    Returns one or more HTML lines that can be used to display the tree branch.
2088    
2089    =back
2090    
2091    =cut
2092    
2093    sub ShowBranch {
2094        # Get the parameters.
2095        my ($cgi, $label, $id, $branch, $options, $displayType) = @_;
2096        # Declare the return variable.
2097        my @retVal = ();
2098        # Start the branch.
2099        push @retVal, $cgi->start_ul({ id => $id, style => "display:$displayType" });
2100        # Check for the hash and choose the start location accordingly.
2101        my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0);
2102        # Get the list length.
2103        my $i1 = scalar(@{$branch});
2104        # Verify we have an even number of elements.
2105        if (($i1 - $i0) % 2 != 0) {
2106            Trace("Branch elements are from $i0 to $i1.") if T(3);
2107            Confess("Odd number of elements in tree branch $label.");
2108        } else {
2109            # Loop through the elements.
2110            for (my $i = $i0; $i < $i1; $i += 2) {
2111                # Get this node's label and contents.
2112                my ($myLabel, $myContent) = ($branch->[$i], $branch->[$i+1]);
2113                # Get an ID for this node's children (if any).
2114                my $myID = GetDivID($options->{name});
2115                # Now we need to find the list of children and the options hash.
2116                # This is a bit ugly because we allow the shortcut of a hash without an
2117                # enclosing list. First, we need some variables.
2118                my $attrHash = {};
2119                my @childHtml = ();
2120                my $hasChildren = 0;
2121                if (! ref $myContent) {
2122                    Confess("Invalid tree definition. Scalar found as content of node \"$myLabel\".");
2123                } elsif (ref $myContent eq 'HASH') {
2124                    # Here the node is a leaf and its content contains the link/value hash.
2125                    $attrHash = $myContent;
2126                } elsif (ref $myContent eq 'ARRAY') {
2127                    # Here the node may be a branch. Its content is a list.
2128                    my $len = scalar @{$myContent};
2129                    if ($len >= 1) {
2130                        # Here the first element of the list could by the link/value hash.
2131                        if (ref $myContent->[0] eq 'HASH') {
2132                            $attrHash = $myContent->[0];
2133                            # If there's data in the list besides the hash, it's our child list.
2134                            # We can pass the entire thing as the child list, because the hash
2135                            # is ignored.
2136                            if ($len > 1) {
2137                                $hasChildren = 1;
2138                            }
2139                        } else {
2140                            $hasChildren = 1;
2141                        }
2142                        # If we have children, create the child list with a recursive call.
2143                        if ($hasChildren) {
2144                            Trace("Processing children of $myLabel.") if T(4);
2145                            push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2146                        }
2147                    }
2148                }
2149                # Okay, it's time to pause and take stock. We have the label of the current node
2150                # in $myLabel, its attributes in $attrHash, and if it is NOT a leaf node, we
2151                # have a child list in @childHtml. If it IS a leaf node, $hasChildren is 0.
2152                # Compute the image HTML. It's tricky, because we have to deal with the open and
2153                # closed images.
2154                my @images = ($options->{nodeImageOpen}, $options->{nodeImageClosed});
2155                my $image = $images[$hasChildren];
2156                my $prefixHtml = $cgi->img({src => $image, id => "${myID}img"});
2157                if ($hasChildren) {
2158                    # If there are children, we wrap the image in a toggle hyperlink.
2159                    $prefixHtml = $cgi->a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" },
2160                                          $prefixHtml);
2161                }
2162                # Now the radio button, if any. Note we use "defined" in case the user wants the
2163                # value to be 0.
2164                if (defined $attrHash->{value}) {
2165                    # Due to a glitchiness in the CGI stuff, we have to build the attribute
2166                    # hash for the "input" method. If the item is pre-selected, we add
2167                    # "checked => undef" to the hash. Otherwise, we can't have "checked"
2168                    # at all.
2169                    my $radioParms = { type => 'radio',
2170                                       name => $options->{name},
2171                                       value => $attrHash->{value},
2172                                     };
2173                    if (defined $options->{selected} && $options->{selected} eq $attrHash->{value}) {
2174                        $radioParms->{checked} = undef;
2175                    }
2176                    $prefixHtml .= $cgi->input($radioParms);
2177                }
2178                # Next, we format the label.
2179                my $labelHtml = $myLabel;
2180                Trace("Formatting tree node for $myLabel.") if T(4);
2181                # Apply a hyperlink if necessary.
2182                if (defined $attrHash->{link}) {
2183                    $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
2184                                         $labelHtml);
2185                }
2186                # Finally, roll up the child HTML. If there are no children, we'll get a null string
2187                # here.
2188                my $childHtml = join("\n", @childHtml);
2189                # Now we have all the pieces, so we can put them together.
2190                push @retVal, $cgi->li("$prefixHtml$labelHtml$childHtml");
2191            }
2192        }
2193        # Close the tree branch.
2194        push @retVal, $cgi->end_ul();
2195        # Return the result.
2196        return @retVal;
2197    }
2198    
2199    =head3 GetDivID
2200    
2201    C<< my $idString = SearchHelper::GetDivID($name); >>
2202    
2203    Return a new HTML ID string.
2204    
2205    =over 4
2206    
2207    =item name
2208    
2209    Name to be prefixed to the ID string.
2210    
2211    =item RETURN
2212    
2213    Returns a hopefully-unique ID string.
2214    
2215    =back
2216    
2217    =cut
2218    
2219    sub GetDivID {
2220        # Get the parameters.
2221        my ($name) = @_;
2222        # Compute the ID.
2223        my $retVal = "elt_$name$divCount";
2224        # Increment the counter to make sure this ID is not re-used.
2225        $divCount++;
2226        # Return the result.
2227        return $retVal;
2228    }
2229    
2230  =head2 Feature Column Methods  =head2 Feature Column Methods
2231    
2232  The methods in this column manage feature column data. If you want to provide the  The methods in this section manage feature column data. If you want to provide the
2233  capability to include new types of data in feature columns, then all the changes  capability to include new types of data in feature columns, then all the changes
2234  are made to this section of the source file. Technically, this should be implemented  are made to this section of the source file. Technically, this should be implemented
2235  using object-oriented methods, but this is simpler for non-programmers to maintain.  using object-oriented methods, but this is simpler for non-programmers to maintain.
# Line 1703  Line 2247 
2247    
2248  =head3 DefaultFeatureColumns  =head3 DefaultFeatureColumns
2249    
2250  C<< my $colNames = $shelp->DefaultFeatureColumns(); >>  C<< my @colNames = $shelp->DefaultFeatureColumns(); >>
2251    
2252  Return a reference to a list of the default feature column identifiers. These  Return a list of the default feature column identifiers. These identifiers can
2253  identifiers can be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in  be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in order to
2254  order to produce the column titles and row values.  produce the column titles and row values.
2255    
2256  =cut  =cut
2257    
# Line 1715  Line 2259 
2259      # Get the parameters.      # Get the parameters.
2260      my ($self) = @_;      my ($self) = @_;
2261      # Return the result.      # Return the result.
2262      return ['orgName', 'function', 'gblink', 'protlink'];      return qw(orgName function gblink protlink);
2263  }  }
2264    
2265  =head3 FeatureColumnTitle  =head3 FeatureColumnTitle
# Line 1747  Line 2291 
2291      if ($colName =~ /^X=(.+)$/) {      if ($colName =~ /^X=(.+)$/) {
2292          # Here we have an extra column.          # Here we have an extra column.
2293          $retVal = $1;          $retVal = $1;
     } elsif ($colName eq 'orgName') {  
         $retVal = "Name";  
     } elsif ($colName eq 'fid') {  
         $retVal = "FIG ID";  
2294      } elsif ($colName eq 'alias') {      } elsif ($colName eq 'alias') {
2295          $retVal = "External Aliases";          $retVal = "External Aliases";
2296        } elsif ($colName eq 'fid') {
2297            $retVal = "FIG ID";
2298      } elsif ($colName eq 'function') {      } elsif ($colName eq 'function') {
2299          $retVal = "Functional Assignment";          $retVal = "Functional Assignment";
2300      } elsif ($colName eq 'gblink') {      } elsif ($colName eq 'gblink') {
2301          $retVal = "GBrowse";          $retVal = "GBrowse";
     } elsif ($colName eq 'protlink') {  
         $retVal = "NMPDR Protein Page";  
2302      } elsif ($colName eq 'group') {      } elsif ($colName eq 'group') {
2303          $retVal = "NMDPR Group";          $retVal = "NMDPR Group";
2304        } elsif ($colName =~ /^keyword:(.+)$/) {
2305            $retVal = ucfirst $1;
2306        } elsif ($colName eq 'orgName') {
2307            $retVal = "Organism and Gene ID";
2308        } elsif ($colName eq 'protlink') {
2309            $retVal = "NMPDR Protein Page";
2310        } elsif ($colName eq 'subsystem') {
2311            $retVal = "Subsystems";
2312      }      }
2313      # Return the result.      # Return the result.
2314      return $retVal;      return $retVal;
2315  }  }
2316    
2317    
2318  =head3 FeatureColumnValue  =head3 FeatureColumnValue
2319    
2320  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>
# Line 1816  Line 2365 
2365          if (defined $extraCols->{$1}) {          if (defined $extraCols->{$1}) {
2366              $retVal = $extraCols->{$1};              $retVal = $extraCols->{$1};
2367          }          }
     } elsif ($colName eq 'orgName') {  
         # Here we want the formatted organism name and feature number.  
         $retVal = $self->FeatureName($fid);  
     } elsif ($colName eq 'fid') {  
         # Here we have the raw feature ID. We hyperlink it to the protein page.  
         $retVal = HTML::set_prot_links($fid);  
2368      } elsif ($colName eq 'alias') {      } elsif ($colName eq 'alias') {
2369          # In this case, the user wants a list of external aliases for the feature.          # In this case, the user wants a list of external aliases for the feature.
2370          # These are very expensive, so we compute them when the row is displayed.          # These are very expensive, so we compute them when the row is displayed.
2371          $retVal = "%%aliases=$fid";          $retVal = "%%alias=$fid";
2372        } elsif ($colName eq 'fid') {
2373            # Here we have the raw feature ID. We hyperlink it to the protein page.
2374            $retVal = HTML::set_prot_links($fid);
2375      } elsif ($colName eq 'function') {      } elsif ($colName eq 'function') {
2376          # The functional assignment is just a matter of getting some text.          # The functional assignment is just a matter of getting some text.
2377          ($retVal) = $record->Value('Feature(assignment)');          ($retVal) = $record->Value('Feature(assignment)');
2378      } elsif ($colName eq 'gblink') {      } elsif ($colName eq 'gblink') {
2379          # 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.
2380          my $gurl = "GetGBrowse.cgi?fid=$fid";          $retVal = Formlet('GBrowse', "GetGBrowse.cgi", undef,
2381          $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 })  
                          );  
2382      } elsif ($colName eq 'group') {      } elsif ($colName eq 'group') {
2383          # Get the NMPDR group name.          # Get the NMPDR group name.
2384          my (undef, $group) = $self->OrganismData($fid);          my (undef, $group) = $self->OrganismData($fid);
# Line 1850  Line 2386 
2386          my $nurl = $sprout->GroupPageName($group);          my $nurl = $sprout->GroupPageName($group);
2387          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },
2388                            $group);                            $group);
2389        } elsif ($colName =~ /^keyword:(.+)$/) {
2390            # Here we want keyword-related values. This is also expensive, so
2391            # we compute them when the row is displayed.
2392            $retVal = "%%$colName=$fid";
2393        } elsif ($colName eq 'orgName') {
2394            # Here we want the formatted organism name and feature number.
2395            $retVal = $self->FeatureName($fid);
2396        } elsif ($colName eq 'protlink') {
2397            # Here we want a link to the protein page using the official NMPDR button.
2398            $retVal = Formlet('NMPDR', "protein.cgi", undef,
2399                              prot => $fid, SPROUT => 1, new_framework => 0,
2400                              user => '');
2401        }elsif ($colName eq 'subsystem') {
2402            # Another run-time column: subsystem list.
2403            $retVal = "%%subsystem=$fid";
2404      }      }
2405      # Return the result.      # Return the result.
2406      return $retVal;      return $retVal;
# Line 1888  Line 2439 
2439      # Get the Sprout and CGI objects.      # Get the Sprout and CGI objects.
2440      my $sprout = $self->DB();      my $sprout = $self->DB();
2441      my $cgi = $self->Q();      my $cgi = $self->Q();
2442        Trace("Runtime column $type with text \"$text\" found.") if T(4);
2443      # Separate the text into a type and data.      # Separate the text into a type and data.
2444      if ($type eq 'aliases') {      if ($type eq 'alias') {
2445          # Here the caller wants external alias links for a feature. The text          # Here the caller wants external alias links for a feature. The text
2446          # is the feature ID.          # is the feature ID.
2447          my $fid = $text;          my $fid = $text;
# Line 1904  Line 2456 
2456              # Ask the HTML processor to hyperlink them.              # Ask the HTML processor to hyperlink them.
2457              $retVal = HTML::set_prot_links($cgi, $aliasList);              $retVal = HTML::set_prot_links($cgi, $aliasList);
2458          }          }
2459        } elsif ($type eq 'subsystem') {
2460            # Here the caller wants the subsystems in which this feature participates.
2461            # The text is the feature ID. We will list the subsystem names with links
2462            # to the subsystem's summary page.
2463            my $fid = $text;
2464            # Get the subsystems.
2465            Trace("Generating subsystems for feature $fid.") if T(4);
2466            my %subs = $sprout->SubsystemsOf($fid);
2467            # Extract the subsystem names.
2468            my @names = map { HTML::sub_link($cgi, $_) } sort keys %subs;
2469            # String them into a list.
2470            $retVal = join(", ", @names);
2471        } elsif ($type =~ /^keyword:(.+)$/) {
2472            # Here the caller wants the value of the named keyword. The text is the
2473            # feature ID.
2474            my $keywordName = $1;
2475            my $fid = $text;
2476            # Get the attribute values.
2477            Trace("Getting $keywordName values for feature $fid.") if T(4);
2478            my @values = $sprout->GetFlat(['Feature'], "Feature(id) = ?", [$fid],
2479                                          "Feature($keywordName)");
2480            # String them into a list.
2481            $retVal = join(", ", @values);
2482        }
2483        # Return the result.
2484        return $retVal;
2485    }
2486    
2487    =head3 SaveOrganismData
2488    
2489    C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain); >>
2490    
2491    Format the name of an organism and the display version of its group name. The incoming
2492    data should be the relevant fields from the B<Genome> record in the database. The
2493    data will also be stored in the genome cache for later use in posting search results.
2494    
2495    =over 4
2496    
2497    =item group
2498    
2499    Name of the genome's group as it appears in the database.
2500    
2501    =item genomeID
2502    
2503    ID of the relevant genome.
2504    
2505    =item genus
2506    
2507    Genus of the genome's organism. If undefined or null, it will be assumed the genome is not
2508    in the database. In this case, the organism name is derived from the genomeID and the group
2509    is automatically the supporting-genomes group.
2510    
2511    =item species
2512    
2513    Species of the genome's organism.
2514    
2515    =item strain
2516    
2517    Strain of the species represented by the genome.
2518    
2519    =item RETURN
2520    
2521    Returns a two-element list. The first element is the formatted genome name. The second
2522    element is the display name of the genome's group.
2523    
2524    =back
2525    
2526    =cut
2527    
2528    sub SaveOrganismData {
2529        # Get the parameters.
2530        my ($self, $group, $genomeID, $genus, $species, $strain) = @_;
2531        # Declare the return values.
2532        my ($name, $displayGroup);
2533        # If the organism does not exist, format an unknown name and a blank group.
2534        if (! defined($genus)) {
2535            $name = "Unknown Genome $genomeID";
2536            $displayGroup = "";
2537        } else {
2538            # It does exist, so format the organism name.
2539            $name = "$genus $species";
2540            if ($strain) {
2541                $name .= " $strain";
2542            }
2543            # Compute the display group. This is currently the same as the incoming group
2544            # name unless it's the supporting group, which is nulled out.
2545            $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2546        }
2547        # Cache the group and organism data.
2548        my $cache = $self->{orgs};
2549        $cache->{$genomeID} = [$name, $displayGroup];
2550        # Return the result.
2551        return ($name, $displayGroup);
2552    }
2553    
2554    =head3 ValidateKeywords
2555    
2556    C<< my $okFlag = $shelp->ValidateKeywords($keywordString, $required); >>
2557    
2558    Insure that a keyword string is reasonably valid. If it is invalid, a message will be
2559    set.
2560    
2561    =over 4
2562    
2563    =item keywordString
2564    
2565    Keyword string specified as a parameter to the current search.
2566    
2567    =item required
2568    
2569    TRUE if there must be at least one keyword specified, else FALSE.
2570    
2571    =item RETURN
2572    
2573    Returns TRUE if the keyword string is valid, else FALSE. Note that a null keyword string
2574    is acceptable if the I<$required> parameter is not specified.
2575    
2576    =back
2577    
2578    =cut
2579    
2580    sub ValidateKeywords {
2581        # Get the parameters.
2582        my ($self, $keywordString, $required) = @_;
2583        # Declare the return variable.
2584        my $retVal = 0;
2585        my @wordList = split /\s+/, $keywordString;
2586        # Right now our only real worry is a list of all minus words. The problem with it is that
2587        # it will return an incorrect result.
2588        my @plusWords = grep { $_ =~ /^[^\-]/ } @wordList;
2589        if (! @wordList) {
2590            if ($required) {
2591                $self->SetMessage("No search words specified.");
2592            } else {
2593                $retVal = 1;
2594            }
2595        } elsif (! @plusWords) {
2596            $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
2597        } else {
2598            $retVal = 1;
2599        }
2600        # Return the result.
2601        return $retVal;
2602    }
2603    
2604    =head3 Formlet
2605    
2606    C<< my $html = SearchHelper::Formlet($caption, $url, $target, %parms); >>
2607    
2608    Create a mini-form that posts to the specified URL with the specified parameters. The
2609    parameters will be stored in hidden fields, and the form's only visible control will
2610    be a submit button with the specified caption.
2611    
2612    Note that we don't use B<CGI.pm> services here because they generate forms with extra characters
2613    and tags that we don't want to deal with.
2614    
2615    =over 4
2616    
2617    =item caption
2618    
2619    Caption to be put on the form button.
2620    
2621    =item url
2622    
2623    URL to be put in the form's action parameter.
2624    
2625    =item target
2626    
2627    Frame or target in which the form results should appear. If C<undef> is specified,
2628    the default target will be used.
2629    
2630    =item parms
2631    
2632    Hash containing the parameter names as keys and the parameter values as values.
2633    
2634    =back
2635    
2636    =cut
2637    
2638    sub Formlet {
2639        # Get the parameters.
2640        my ($caption, $url, $target, %parms) = @_;
2641        # Compute the target HTML.
2642        my $targetHtml = ($target ? " target=\"$target\"" : "");
2643        # Start the form.
2644        my $retVal = "<form method=\"POST\" action=\"$url\"$target>";
2645        # Add the parameters.
2646        for my $parm (keys %parms) {
2647            $retVal .= "<input type=\"hidden\" name=\"$parm\" value=\"$parms{$parm}\" />";
2648        }
2649        # Put in the button.
2650        $retVal .= "<input type=\"submit\" name=\"submit\" value=\"$caption\" class=\"button\" />";
2651        # Close the form.
2652        $retVal .= "</form>";
2653        # Return the result.
2654        return $retVal;
2655      }      }
2656    
2657    =head2 Virtual Methods
2658    
2659    =head3 Form
2660    
2661    C<< my $html = $shelp->Form(); >>
2662    
2663    Generate the HTML for a form to request a new search.
2664    
2665    =head3 Find
2666    
2667    C<< my $resultCount = $shelp->Find(); >>
2668    
2669    Conduct a search based on the current CGI query parameters. The search results will
2670    be written to the session cache file and the number of results will be
2671    returned. If the search parameters are invalid, a result count of C<undef> will be
2672    returned and a result message will be stored in this object describing the problem.
2673    
2674    =head3 Description
2675    
2676    C<< my $htmlText = $shelp->Description(); >>
2677    
2678    Return a description of this search. The description is used for the table of contents
2679    on the main search tools page. It may contain HTML, but it should be character-level,
2680    not block-level, since the description is going to appear in a list.
2681    
2682    =head3 SortKey
2683    
2684    C<< my $key = $shelp->SortKey($fdata); >>
2685    
2686    Return the sort key for the specified feature data. The default is to sort by feature name,
2687    floating NMPDR organisms to the top. If a full-text search is used, then the default
2688    sort is by relevance followed by feature name. This sort may be overridden by the
2689    search class to provide fancier functionality. This method is called by
2690    B<PutFeature>, so it is only used for feature searches. A non-feature search
2691    would presumably have its own sort logic.
2692    
2693    =over 4
2694    
2695    =item record
2696    
2697    The C<FeatureData> containing the current feature.
2698    
2699    =item RETURN
2700    
2701    Returns a key field that can be used to sort this row in among the results.
2702    
2703    =back
2704    
2705    =cut
2706    
2707    sub SortKey {
2708        # Get the parameters.
2709        my ($self, $fdata) = @_;
2710        # Get the feature ID from the record.
2711        my $fid = $fdata->FID();
2712        # Get the group from the feature ID.
2713        my $group = $self->FeatureGroup($fid);
2714        # Ask the feature query object to form the sort key.
2715        my $retVal = $fdata->SortKey($self, $group);
2716      # Return the result.      # Return the result.
2717      return $retVal;      return $retVal;
2718  }  }

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.22

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3