[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.19, Mon Nov 20 05:54:09 2006 UTC revision 1.32, Thu May 17 23:43:30 2007 UTC
# Line 88  Line 88 
88  TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this  TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this
89  field is updated by the B<FeatureQuery> object.  field is updated by the B<FeatureQuery> object.
90    
91    =item extraPos
92    
93    Hash indicating which extra columns should be put at the end. Extra columns
94    not mentioned in this hash are put at the beginning. Use the L</SetExtraPos>
95    method to change this option.
96    
97  =back  =back
98    
99  =head2 Adding a new Search Tool  =head2 Adding a new Search Tool
# Line 230  Line 236 
236  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
237  above code is just a loose framework.  above code is just a loose framework.
238    
239    In addition to the finding and filtering, it is necessary to send status messages
240    to the output so that the user does not get bored waiting for results. The L</PrintLine>
241    method performs this function. The single parameter should be text to be
242    output to the browser. In general, you'll invoke it as follows.
243    
244        $self->PrintLine("...my message text...<br />");
245    
246    The break tag is optional. When the Find method gets control, a paragraph will
247    have been started so that everything is XHTML-compliant.
248    
249  If you wish to add your own extra columns to the output, use the B<AddExtraColumns>  If you wish to add your own extra columns to the output, use the B<AddExtraColumns>
250  method of the feature query object.  method of the feature query object.
251    
# Line 251  Line 267 
267    
268  =head3 new  =head3 new
269    
270  C<< my $shelp = SearchHelper->new($query); >>  C<< my $shelp = SearchHelper->new($cgi); >>
271    
272  Construct a new SearchHelper object.  Construct a new SearchHelper object.
273    
# Line 272  Line 288 
288      my $session_id = $cgi->param("SessionID");      my $session_id = $cgi->param("SessionID");
289      my $type = "old";      my $type = "old";
290      if (! $session_id) {      if (! $session_id) {
291            Trace("No session ID found.") if T(3);
292          # 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
293          # store it in the query object.          # store it in the query object.
294          $session_id = NewSessionID();          $session_id = NewSessionID();
295          $type = "new";          $type = "new";
296          $cgi->param(-name => 'SessionID', -value => $session_id);          $cgi->param(-name => 'SessionID', -value => $session_id);
297        } else {
298            Trace("Session ID is $session_id.") if T(3);
299      }      }
300      # Compute the subclass name.      # Compute the subclass name.
301      my $subClass;      my $subClass;
# Line 307  Line 326 
326                    genomeList => undef,                    genomeList => undef,
327                    genomeParms => [],                    genomeParms => [],
328                    filtered => 0,                    filtered => 0,
329                      extraPos => {},
330                   };                   };
331      # Bless and return it.      # Bless and return it.
332      bless $retVal, $class;      bless $retVal, $class;
# Line 367  Line 387 
387      return ($self->{type} eq 'new');      return ($self->{type} eq 'new');
388  }  }
389    
390    =head3 SetExtraPos
391    
392    C<< $shelp->SetExtraPos(@columnMap); >>
393    
394    Indicate whether the extra columns should be in the front (C<0>) or end (C<1>) columns of the results.
395    
396    =over 4
397    
398    =item columnMap
399    
400    A list of extra columns to display at the end.
401    
402    =back
403    
404    =cut
405    
406    sub SetExtraPos {
407        # Get the parameters.
408        my ($self, @columnMap) = @_;
409        # Convert the column map to a hash.
410        my %map = map { $_ => 1 } @columnMap;
411        # Save a reference to it.
412        $self->{extraPos} = \%map;
413    }
414    
415  =head3 ID  =head3 ID
416    
417  C<< my $sessionID = $shelp->ID(); >>  C<< my $sessionID = $shelp->ID(); >>
# Line 669  Line 714 
714      # Check for a first-call situation.      # Check for a first-call situation.
715      if (! defined $self->{cols}) {      if (! defined $self->{cols}) {
716          Trace("Setting up the columns.") if T(3);          Trace("Setting up the columns.") if T(3);
717          # Here we need to set up the column information. Start with the extras,          # Tell the user what's happening.
718          # sorted by column name.          $self->PrintLine("Creating output columns.<br />");
719          my @colNames = ();          # Here we need to set up the column information. First we accumulate the extras,
720            # sorted by column name and separate by whether they go in the beginning or the
721            # end.
722            my @xtraNamesFront = ();
723            my @xtraNamesEnd = ();
724            my $xtraPosMap = $self->{extraPos};
725          for my $col (sort keys %{$extraCols}) {          for my $col (sort keys %{$extraCols}) {
726              push @colNames, "X=$col";              if ($xtraPosMap->{$col}) {
727                    push @xtraNamesEnd, "X=$col";
728                } else {
729                    push @xtraNamesFront, "X=$col";
730                }
731          }          }
732            # Set up the column name array.
733            my @colNames = ();
734            # Put in the extra columns that go in the beginning.
735            push @colNames, @xtraNamesFront;
736          # Add the default columns.          # Add the default columns.
737          push @colNames, $self->DefaultFeatureColumns();          push @colNames, $self->DefaultFeatureColumns();
738          # Add any additional columns requested by the feature filter.          # Add any additional columns requested by the feature filter.
739          push @colNames, FeatureQuery::AdditionalColumns($self);          push @colNames, FeatureQuery::AdditionalColumns($self);
740            # If extras go at the end, put them in here.
741            push @colNames, @xtraNamesEnd;
742            Trace("Full column list determined.") if T(3);
743          # Save the full list.          # Save the full list.
744          $self->{cols} = \@colNames;          $self->{cols} = \@colNames;
745          # Write out the column headers. This also prepares the cache file to receive          # Write out the column names. This also prepares the cache file to receive
746          # output.          # output.
747          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});          Trace("Writing column headers.") if T(3);
748            $self->WriteColumnHeaders(@{$self->{cols}});
749            Trace("Column headers written.") if T(3);
750      }      }
751      # Get the feature ID.      # Get the feature ID.
752      my $fid = $fd->FID();      my $fid = $fd->FID();
753      # Loop through the column headers, producing the desired data.      # Loop through the column headers, producing the desired data. The first column
754      my @output = ();      # is the feature ID. The feature ID does not show up in the output: its purpose
755        # is to help the various output formatters.
756        my @output = ($fid);
757      for my $colName (@{$self->{cols}}) {      for my $colName (@{$self->{cols}}) {
758          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
759      }      }
# Line 726  Line 791 
791      # Write the column headers and close the file.      # Write the column headers and close the file.
792      Tracer::PutLine($handle1, \@colNames);      Tracer::PutLine($handle1, \@colNames);
793      close $handle1;      close $handle1;
794        Trace("Column headers are: " . join("; ", @colNames) . ".") if T(3);
795      # Now open the sort pipe and save the file handle. Note how we append the      # Now open the sort pipe and save the file handle. Note how we append the
796      # sorted data to the column header row already in place. The output will      # sorted data to the column header row already in place. The output will
797      # contain a sort key followed by the real columns. The sort key is      # contain a sort key followed by the real columns. The sort key is
# Line 759  Line 825 
825      my ($self, $key, @colValues) = @_;      my ($self, $key, @colValues) = @_;
826      # Write them to the cache file.      # Write them to the cache file.
827      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);
828        Trace("Column data is " . join("; ", $key, @colValues) . ".") if T(4);
829  }  }
830    
831  =head3 CloseSession  =head3 CloseSession
# Line 777  Line 844 
844          # We found one, so close it.          # We found one, so close it.
845          Trace("Closing session file.") if T(2);          Trace("Closing session file.") if T(2);
846          close $self->{fileHandle};          close $self->{fileHandle};
847            # Tell the user.
848            my $cgi = $self->Q();
849            $self->PrintLine("Output formatting complete.<br />");
850      }      }
851  }  }
852    
# Line 819  Line 889 
889    
890  =item RETURN  =item RETURN
891    
892  Returns a list of two items. The first item in the list is the organism name,  Returns a list of three items. The first item in the list is the organism name,
893  and the second is the name of the NMPDR group, or an empty string if the  and the second is the name of the NMPDR group, or an empty string if the
894  organism is not in an NMPDR group.  organism is not in an NMPDR group. The third item is the organism's domain.
895    
896  =back  =back
897    
# Line 831  Line 901 
901      # Get the parameters.      # Get the parameters.
902      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
903      # Declare the return variables.      # Declare the return variables.
904      my ($orgName, $group);      my ($orgName, $group, $domain);
905      # Check the cache.      # Check the cache.
906      my $cache = $self->{orgs};      my $cache = $self->{orgs};
907      if (exists $cache->{$genomeID}) {      if (exists $cache->{$genomeID}) {
908          ($orgName, $group) = @{$cache->{$genomeID}};          ($orgName, $group, $domain) = @{$cache->{$genomeID}};
909      } else {      } else {
910          # Here we have to use the database.          # Here we have to use the database.
911          my $sprout = $self->DB();          my $sprout = $self->DB();
912          my ($genus, $species, $strain, $group) = $sprout->GetEntityValues('Genome', $genomeID,          my ($genus, $species, $strain, $group, $taxonomy) = $sprout->GetEntityValues('Genome', $genomeID,
913                                                      ['Genome(genus)', 'Genome(species)',                                                      ['Genome(genus)', 'Genome(species)',
914                                                       'Genome(unique-characterization)',                                                       'Genome(unique-characterization)',
915                                                       'Genome(primary-group)']);                                                                   'Genome(primary-group)',
916                                                                     'Genome(taxonomy)']);
917          # Format and cache the name and display group.          # Format and cache the name and display group.
918          ($orgName, $group) = $self->SaveOrganismData($group, $genomeID, $genus, $species,          ($orgName, $group, $domain) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
919                                                              $strain);                                                                $strain, $taxonomy);
920      }      }
921      # Return the result.      # Return the result.
922      return ($orgName, $group);      return ($orgName, $group, $domain);
923  }  }
924    
925  =head3 Organism  =head3 Organism
# Line 876  Line 947 
947      # Get the parameters.      # Get the parameters.
948      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
949      # Get the organism data.      # Get the organism data.
950      my ($retVal, $group) = $self->OrganismData($genomeID);      my ($retVal) = $self->OrganismData($genomeID);
951      # Return the result.      # Return the result.
952      return $retVal;      return $retVal;
953  }  }
# Line 956  Line 1027 
1027    
1028  =head3 ComputeFASTA  =head3 ComputeFASTA
1029    
1030  C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence); >>  C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence, $flankingWidth); >>
1031    
1032  Parse a sequence input and convert it into a FASTA string of the desired type.  Parse a sequence input and convert it into a FASTA string of the desired type with
1033    the desired flanking width.
1034    
1035  =over 4  =over 4
1036    
# Line 974  Line 1046 
1046  if the input does not begin with a greater-than sign (FASTA label line), a default label  if the input does not begin with a greater-than sign (FASTA label line), a default label
1047  line will be provided.  line will be provided.
1048    
1049    =item flankingWidth
1050    
1051    If the DNA FASTA of a feature is desired, the number of base pairs to either side of the
1052    feature that should be included. Currently we can't do this for Proteins because the
1053    protein translation of a feature doesn't always match the DNA and is taken directly
1054    from the database.
1055    
1056  =item RETURN  =item RETURN
1057    
1058  Returns a string in FASTA format representing the content of the desired sequence with  Returns a string in FASTA format representing the content of the desired sequence with
# Line 986  Line 1065 
1065    
1066  sub ComputeFASTA {  sub ComputeFASTA {
1067      # Get the parameters.      # Get the parameters.
1068      my ($self, $incomingType, $desiredType, $sequence) = @_;      my ($self, $desiredType, $sequence, $flankingWidth) = @_;
1069      # Declare the return variable. If an error occurs, it will remain undefined.      # Declare the return variable. If an error occurs, it will remain undefined.
1070      my $retVal;      my $retVal;
1071      # This variable will be cleared if an error is detected.      # This variable will be cleared if an error is detected.
# Line 994  Line 1073 
1073      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
1074      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
1075      Trace("FASTA desired type is $desiredType.") if T(4);      Trace("FASTA desired type is $desiredType.") if T(4);
1076      # Check for a feature specification.      # Check for a feature specification. The smoking gun for that is a vertical bar.
1077      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
1078          # 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
1079          # it.          # it.
# Line 1009  Line 1088 
1088              $self->SetMessage("No gene found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
1089              $okFlag = 0;              $okFlag = 0;
1090          } else {          } else {
1091              # Set the FASTA label.              # Set the FASTA label. The ID is the first favored alias.
1092              my $fastaLabel = $fid;              my $favored = $self->Q()->param('FavoredAlias') || 'fig';
1093                my $favorLen = length $favored;
1094                ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid);
1095                if (! $fastaLabel) {
1096                    # In an emergency, fall back to the original ID.
1097                    $fastaLabel = $fid;
1098                }
1099              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
1100              if ($desiredType eq 'prot') {              if ($desiredType eq 'prot') {
1101                  # We want protein, so get the translation.                  # We want protein, so get the translation.
1102                  $fastaData = $sprout->FeatureTranslation($figID);                  $fastaData = $sprout->FeatureTranslation($figID);
1103                  Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);                  Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
1104              } else {              } else {
1105                  # 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. First, we get the
1106                    # locations.
1107                  my @locList = $sprout->FeatureLocation($figID);                  my @locList = $sprout->FeatureLocation($figID);
1108                    if ($flankingWidth > 0) {
1109                        # Here we need to add flanking data. Convert the locations to a list
1110                        # of location objects.
1111                        my @locObjects = map { BasicLocation->new($_) } @locList;
1112                        # Initialize the return variable. We will put the DNA in here segment by segment.
1113                        $fastaData = "";
1114                        # Now we widen each location by the flanking width and stash the results. This
1115                        # requires getting the contig length for each contig so we don't fall off the end.
1116                        for my $locObject (@locObjects) {
1117                            Trace("Current location is " . $locObject->String . ".") if T(4);
1118                            # Remember the current start and length.
1119                            my ($start, $len) = ($locObject->Left, $locObject->Length);
1120                            # Get the contig length.
1121                            my $contigLen = $sprout->ContigLength($locObject->Contig);
1122                            # Widen the location and get its DNA.
1123                            $locObject->Widen($flankingWidth, $contigLen);
1124                            my $fastaSegment = $sprout->DNASeq([$locObject->String()]);
1125                            # Now we need to do some case changing. The main DNA is upper case and
1126                            # the flanking DNA is lower case.
1127                            my $leftFlank = $start - $locObject->Left;
1128                            my $rightFlank = $leftFlank + $len;
1129                            Trace("Wide location is " . $locObject->String . ". Flanks are $leftFlank and $rightFlank. Contig len is $contigLen.") if T(4);
1130                            my $fancyFastaSegment = lc(substr($fastaSegment, 0, $leftFlank)) .
1131                                                    uc(substr($fastaSegment, $leftFlank, $rightFlank - $leftFlank)) .
1132                                                    lc(substr($fastaSegment, $rightFlank));
1133                            $fastaData .= $fancyFastaSegment;
1134                        }
1135                    } else {
1136                        # Here we have just the raw sequence.
1137                  $fastaData = $sprout->DNASeq(\@locList);                  $fastaData = $sprout->DNASeq(\@locList);
1138                  Trace(length $fastaData . " characters returned for DNA of $fastaLabel.") if T(3);                  }
1139                    Trace((length $fastaData) . " characters returned for DNA of $fastaLabel.") if T(3);
1140              }              }
1141          }          }
1142      } else {      } else {
# Line 1042  Line 1158 
1158          $fastaData =~ s/\n//g;          $fastaData =~ s/\n//g;
1159          $fastaData =~ s/\s+//g;          $fastaData =~ s/\s+//g;
1160          # Finally, verify that it's DNA if we're doing DNA stuff.          # Finally, verify that it's DNA if we're doing DNA stuff.
1161          if ($desiredType eq 'dna' && $fastaData =~ /[^agct]/i) {          if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn]/i) {
1162              $self->SetMessage("Invaid characters detected. Is the input really a DNA sequence?");              $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?");
1163              $okFlag = 0;              $okFlag = 0;
1164          }          }
1165      }      }
# Line 1114  Line 1230 
1230      # Read in the subsystems.      # Read in the subsystems.
1231      my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],      my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1232                                 ['Subsystem(classification)', 'Subsystem(id)']);                                 ['Subsystem(classification)', 'Subsystem(id)']);
1233        # Put any unclassified subsystems at the end. They will always be at the beginning, so if one
1234        # is at the end, ALL subsystems are unclassified and we don't bother.
1235        if ($#subs >= 0 && $subs[$#subs]->[0] ne '') {
1236            while ($subs[0]->[0] eq '') {
1237                my $classLess = shift @subs;
1238                push @subs, $classLess;
1239            }
1240        }
1241      # Declare the return variable.      # Declare the return variable.
1242      my @retVal = ();      my @retVal = ();
1243      # Each element in @subs represents a leaf node, so as we loop through it we will be      # Each element in @subs represents a leaf node, so as we loop through it we will be
# Line 1188  Line 1312 
1312              if ($optionThing->{links}) {              if ($optionThing->{links}) {
1313                  # Compute the link value.                  # Compute the link value.
1314                  my $linkable = uri_escape($id);                  my $linkable = uri_escape($id);
1315                  $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;SPROUT=1";                  $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;show_clusters=1;SPROUT=1";
1316              }              }
1317              if ($optionThing->{radio}) {              if ($optionThing->{radio}) {
1318                  # Compute the radio value.                  # Compute the radio value.
# Line 1263  Line 1387 
1387      # Get the form name.      # Get the form name.
1388      my $formName = $self->FormName();      my $formName = $self->FormName();
1389      # Check to see if we already have a genome list in memory.      # Check to see if we already have a genome list in memory.
     my $genomes = $self->{genomeList};  
1390      my $groupHash;      my $groupHash;
1391        my @groups;
1392        my $nmpdrGroupCount;
1393        my $genomes = $self->{genomeList};
1394      if (defined $genomes) {      if (defined $genomes) {
1395          # We have a list ready to use.          # We have a list ready to use.
1396          $groupHash = $genomes;          $groupHash = $genomes;
1397            @groups = @{$self->{groupList}};
1398            $nmpdrGroupCount = $self->{groupCount};
1399      } else {      } else {
1400          # 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
1401          # 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
# Line 1276  Line 1404 
1404                                           "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",                                           "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",
1405                                           [], ['Genome(primary-group)', 'Genome(id)',                                           [], ['Genome(primary-group)', 'Genome(id)',
1406                                                'Genome(genus)', 'Genome(species)',                                                'Genome(genus)', 'Genome(species)',
1407                                                'Genome(unique-characterization)']);                                                'Genome(unique-characterization)',
1408                                                  'Genome(taxonomy)']);
1409          # 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
1410          # 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
1411          # name.          # name.
1412          my %gHash = ();          my %gHash = ();
1413          for my $genome (@genomeList) {          for my $genome (@genomeList) {
1414              # Get the genome data.              # Get the genome data.
1415              my ($group, $genomeID, $genus, $species, $strain) = @{$genome};              my ($group, $genomeID, $genus, $species, $strain, $taxonomy) = @{$genome};
1416              # Compute and cache its name and display group.              # Compute and cache its name and display group.
1417              my ($name, $displayGroup) = $self->SaveOrganismData($group, $genomeID, $genus, $species,              my ($name, $displayGroup, $domain) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1418                                                                  $strain);                                                                           $strain, $taxonomy);
1419              # Push the genome into the group's list. Note that we use the real group              # Push the genome into the group's list. Note that we use the real group
1420              # name here, not the display group name.              # name here, not the display group name.
1421              push @{$gHash{$group}}, [$genomeID, $name];              push @{$gHash{$group}}, [$genomeID, $name, $domain];
1422            }
1423            # We are almost ready to unroll the menu out of the group hash. The final step is to separate
1424            # the supporting genomes by domain. First, we sort the NMPDR groups.
1425            @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %gHash;
1426            # Remember the number of NMPDR groups.
1427            $nmpdrGroupCount = scalar @groups;
1428            # Loop through the supporting genomes, classifying them by domain. We'll also keep a list
1429            # of the domains found.
1430            my @otherGenomes = @{$gHash{$FIG_Config::otherGroup}};
1431            my @domains = ();
1432            for my $genomeData (@otherGenomes) {
1433                my ($genomeID, $name, $domain) = @{$genomeData};
1434                if (exists $gHash{$domain}) {
1435                    push @{$gHash{$domain}}, $genomeData;
1436                } else {
1437                    $gHash{$domain} = [$genomeData];
1438                    push @domains, $domain;
1439                }
1440          }          }
1441            # Add the domain groups at the end of the main group list. The main group list will now
1442            # contain all the categories we need to display the genomes.
1443            push @groups, sort @domains;
1444            # Delete the supporting group.
1445            delete $gHash{$FIG_Config::otherGroup};
1446          # Save the genome list for future use.          # Save the genome list for future use.
1447          $self->{genomeList} = \%gHash;          $self->{genomeList} = \%gHash;
1448            $self->{groupList} = \@groups;
1449            $self->{groupCount} = $nmpdrGroupCount;
1450          $groupHash = \%gHash;          $groupHash = \%gHash;
1451      }      }
     # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting  
     # the supporting-genome group last.  
     my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %{$groupHash};  
     push @groups, $FIG_Config::otherGroup;  
1452      # Next, create a hash that specifies the pre-selected entries. Note that we need to deal      # Next, create a hash that specifies the pre-selected entries. Note that we need to deal
1453      # with the possibility of undefined values in the incoming list.      # with the possibility of undefined values in the incoming list.
1454      my %selectedHash = ();      my %selectedHash = ();
# Line 1335  Line 1485 
1485          # Get the genomes in the group.          # Get the genomes in the group.
1486          for my $genome (@{$groupHash->{$group}}) {          for my $genome (@{$groupHash->{$group}}) {
1487              # Count this organism if it's NMPDR.              # Count this organism if it's NMPDR.
1488              if ($group ne $FIG_Config::otherGroup) {              if ($nmpdrGroupCount > 0) {
1489                  $nmpdrCount++;                  $nmpdrCount++;
1490              }              }
1491              # Get the organism ID and name.              # Get the organism ID, name, and domain.
1492              my ($genomeID, $name) = @{$genome};              my ($genomeID, $name, $domain) = @{$genome};
1493              # See if it's selected.              # See if it's selected.
1494              my $select = ($selectedHash{$genomeID} ? " selected" : "");              my $select = ($selectedHash{$genomeID} ? " selected" : "");
1495              # Generate the option tag.              # Generate the option tag.
1496              my $optionTag = "<OPTION value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";              my $optionTag = "<OPTION class=\"$domain\" value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";
1497              push @lines, "    $optionTag";              push @lines, "    $optionTag";
1498          }          }
1499          # Close the option group.          # Close the option group.
1500          push @lines, "  </OPTGROUP>";          push @lines, "  </OPTGROUP>";
1501            # Record this group in the nmpdrGroup count. When that gets to 0, we've finished the NMPDR
1502            # groups.
1503            $nmpdrGroupCount--;
1504      }      }
1505      # Close the SELECT tag.      # Close the SELECT tag.
1506      push @lines, "</SELECT>";      push @lines, "</SELECT>";
# Line 1452  Line 1605 
1605  =item rows  =item rows
1606    
1607  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
1608  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
1609  set the width. Everything else will be left as is.  will be modified to set the width. Everything else will be left as is.
1610    
1611  =item RETURN  =item RETURN
1612    
# Line 1468  Line 1621 
1621      my ($self, $rows) = @_;      my ($self, $rows) = @_;
1622      # Get the CGI object.      # Get the CGI object.
1623      my $cgi = $self->Q();      my $cgi = $self->Q();
1624      # 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.
1625        # This flag will be set to FALSE when that happens.
1626        my $needWidth = 1;
1627      # 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
1628      # is already specified on the first column bad things will happen.      # is already specified on the first column bad things will happen.
1629      for my $row (@{$rows}) {      for my $row (@{$rows}) {
1630          $row =~ s/(<td|th)/$1 width="150"/i;          # See if this row needs a width.
1631            if ($needWidth && $row =~ /<(td|th) ([^>]+)>/i) {
1632                # Here we have a first cell and its tag parameters are in $2.
1633                my $elements = $2;
1634                if ($elements !~ /colspan/i) {
1635                    Trace("No colspan tag found in element \'$elements\'.") if T(3);
1636                    # Here there's no colspan, so we plug in the width. We
1637                    # eschew the "g" modifier on the substitution because we
1638                    # only want to update the first cell.
1639                    $row =~ s/(<(td|th))/$1 width="150"/i;
1640                    # Denote we don't need this any more.
1641                    $needWidth = 0;
1642                }
1643            }
1644      }      }
1645      # Create the table.      # Create the table.
1646      my $retVal = $cgi->table({border => 2, cellspacing => 2,      my $retVal = $cgi->table({border => 2, cellspacing => 2,
# Line 1519  Line 1687 
1687      my $retVal = $cgi->Tr($cgi->td("Results/Page"),      my $retVal = $cgi->Tr($cgi->td("Results/Page"),
1688                            $cgi->td($cgi->popup_menu(-name => 'PageSize',                            $cgi->td($cgi->popup_menu(-name => 'PageSize',
1689                                                      -values => [10, 25, 50, 100, 1000],                                                      -values => [10, 25, 50, 100, 1000],
1690                                                      -default => $pageSize) . " " .                                                      -default => $pageSize)),
                                    $cgi->checkbox(-name => 'ShowURL',  
                                                   -value => 1,  
                                                   -label => 'Show URL')),  
1691                            $cgi->td($cgi->submit(-class => 'goButton',                            $cgi->td($cgi->submit(-class => 'goButton',
1692                                                  -name => 'Search',                                                  -name => 'Search',
1693                                                  -value => $realCaption)));                                                  -value => $realCaption)));
# Line 1532  Line 1697 
1697    
1698  =head3 FeatureFilterRows  =head3 FeatureFilterRows
1699    
1700  C<< my $htmlText = $shelp->FeatureFilterRows(); >>  C<< my $htmlText = $shelp->FeatureFilterRows(@subset); >>
1701    
1702  This method creates table rows that can be used to filter features. The form  This method creates table rows that can be used to filter features. The form
1703  values can be used to select features by genome using the B<FeatureQuery>  values can be used to select features by genome using the B<FeatureQuery>
1704  object.  object.
1705    
1706    =over 4
1707    
1708    =item subset
1709    
1710    List of rows to display. The default (C<all>) is to display all rows.
1711    C<words> displays the word search box, C<subsys> displays the subsystem
1712    selector, and C<options> displays the options row.
1713    
1714    =item RETURN
1715    
1716    Returns the html text for table rows containing the desired feature filtering controls.
1717    
1718    =back
1719    
1720  =cut  =cut
1721    
1722  sub FeatureFilterRows {  sub FeatureFilterRows {
1723      # Get the parameters.      # Get the parameters.
1724      my ($self) = @_;      my ($self, @subset) = @_;
1725        if (@subset == 0 || $subset[0] eq 'all') {
1726            @subset = qw(words subsys options);
1727        }
1728      # Return the result.      # Return the result.
1729      return FeatureQuery::FilterRows($self);      return FeatureQuery::FilterRows($self, @subset);
1730  }  }
1731    
1732  =head3 GBrowseFeatureURL  =head3 GBrowseFeatureURL
# Line 1767  Line 1949 
1949          # a singleton list, but that's okay.          # a singleton list, but that's okay.
1950          my @values = split (/\0/, $parms{$parmKey});          my @values = split (/\0/, $parms{$parmKey});
1951          # Check for special cases.          # Check for special cases.
1952          if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF ShowURL)) {          if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) {
1953              # These are bookkeeping parameters we don't need to start a search.              # These are bookkeeping parameters we don't need to start a search.
1954              @values = ();              @values = ();
1955          } elsif ($parmKey =~ /_SearchThing$/) {          } elsif ($parmKey =~ /_SearchThing$/) {
# Line 1852  Line 2034 
2034    
2035  sub AdvancedClassList {  sub AdvancedClassList {
2036      my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;      my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;
2037      return @retVal;      return sort @retVal;
2038  }  }
2039    
2040  =head3 SelectionTree  =head3 SelectionTree
# Line 2142  Line 2324 
2324                      if ($hasChildren) {                      if ($hasChildren) {
2325                          Trace("Processing children of $myLabel.") if T(4);                          Trace("Processing children of $myLabel.") if T(4);
2326                          push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');                          push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2327                            Trace("Children of $myLabel finished.") if T(4);
2328                      }                      }
2329                  }                  }
2330              }              }
# Line 2176  Line 2359 
2359              }              }
2360              # Next, we format the label.              # Next, we format the label.
2361              my $labelHtml = $myLabel;              my $labelHtml = $myLabel;
2362              Trace("Formatting tree node for $myLabel.") if T(4);              Trace("Formatting tree node for \"$myLabel\".") if T(4);
2363              # Apply a hyperlink if necessary.              # Apply a hyperlink if necessary.
2364              if (defined $attrHash->{link}) {              if (defined $attrHash->{link}) {
2365                  $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },                  $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
# Line 2226  Line 2409 
2409      return $retVal;      return $retVal;
2410  }  }
2411    
2412    
2413    =head3 PrintLine
2414    
2415    C<< $shelp->PrintLine($message); >>
2416    
2417    Print a line of CGI output. This is used during the operation of the B<Find> method while
2418    searching, so the user sees progress in real-time.
2419    
2420    =over 4
2421    
2422    =item message
2423    
2424    HTML text to display.
2425    
2426    =back
2427    
2428    =cut
2429    
2430    sub PrintLine {
2431        # Get the parameters.
2432        my ($self, $message) = @_;
2433        # Send them to the output.
2434        print "$message\n";
2435    }
2436    
2437  =head2 Feature Column Methods  =head2 Feature Column Methods
2438    
2439  The methods in this section 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
# Line 2236  Line 2444 
2444  the name for the protein page link column is C<protlink>. If the column is to appear  the name for the protein page link column is C<protlink>. If the column is to appear
2445  in the default list of feature columns, add it to the list returned by  in the default list of feature columns, add it to the list returned by
2446  L</DefaultFeatureColumns>. Then add code to produce the column title to  L</DefaultFeatureColumns>. Then add code to produce the column title to
2447  L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>, and  L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>. If the
2448  everything else will happen automatically.  feature column should be excluded from downloads, add it to the C<FeatureColumnSkip>
2449    hash. Everything else will happen automatically.
2450    
2451  There is one special column name syntax for extra columns (that is, nonstandard  There is a special column name syntax for extra columns (that is, nonstandard
2452  feature columns). If the column name begins with C<X=>, then it is presumed to be  feature columns). If the column name begins with C<X=>, then it is presumed to be
2453  an extra column. The column title is the text after the C<X=>, and its value is  an extra column. The column title is the text after the C<X=>, and its value is
2454  pulled from the extra column hash.  pulled from the extra column hash.
2455    
2456    =cut
2457    
2458    # This hash is used to determine which columns should not be included in downloads.
2459    my %FeatureColumnSkip = map { $_ => 1 } qw(gblink viewerlink protlink);
2460    
2461  =head3 DefaultFeatureColumns  =head3 DefaultFeatureColumns
2462    
2463  C<< my @colNames = $shelp->DefaultFeatureColumns(); >>  C<< my @colNames = $shelp->DefaultFeatureColumns(); >>
# Line 2303  Line 2517 
2517      } elsif ($colName =~ /^keyword:(.+)$/) {      } elsif ($colName =~ /^keyword:(.+)$/) {
2518          $retVal = ucfirst $1;          $retVal = ucfirst $1;
2519      } elsif ($colName eq 'orgName') {      } elsif ($colName eq 'orgName') {
2520          $retVal = "Gene Name";          $retVal = "Organism and Gene ID";
2521      } elsif ($colName eq 'protlink') {      } elsif ($colName eq 'protlink') {
2522          $retVal = "NMPDR Protein Page";          $retVal = "NMPDR Protein Page";
2523        } elsif ($colName eq 'viewerlink') {
2524            $retVal = "Annotation Page";
2525      } elsif ($colName eq 'subsystem') {      } elsif ($colName eq 'subsystem') {
2526          $retVal = "Subsystems";          $retVal = "Subsystems";
2527        } elsif ($colName eq 'pdb') {
2528            $retVal = "Best PDB Match";
2529      }      }
2530      # Return the result.      # Return the result.
2531      return $retVal;      return $retVal;
2532  }  }
2533    
2534    =head3 FeatureColumnDownload
2535    
2536    C<< my $keep = $shelp->FeatureColumnDownload($colName); >>
2537    
2538    Return TRUE if the named feature column is to be kept when downloading, else FALSE.
2539    
2540    =over 4
2541    
2542    =item colName
2543    
2544    Name of the relevant feature column.
2545    
2546    =item RETURN
2547    
2548    Return TRUE if the named column should be kept while downloading, else FALSE. In general,
2549    FALSE is returned if the column generates a button, image, or other purely-HTML value.
2550    
2551    =back
2552    
2553    =cut
2554    
2555    sub FeatureColumnDownload {
2556        # Get the parameters.
2557        my ($self, $colName) = @_;
2558        # Return the determination. We download the column if it's not in the skip-hash.
2559        # Note we return 0 and 1 instead of 1 and undef because it simplifies some tracing.
2560        return (exists $FeatureColumnSkip{$colName} ? 0 : 1);
2561    }
2562    
2563    
2564  =head3 FeatureColumnValue  =head3 FeatureColumnValue
2565    
# Line 2328  Line 2575 
2575    
2576  =item record  =item record
2577    
2578  DBObject record for the feature being displayed in the current row.  ERDBObject record for the feature being displayed in the current row.
2579    
2580  =item extraCols  =item extraCols
2581    
# Line 2367  Line 2614 
2614      } elsif ($colName eq 'alias') {      } elsif ($colName eq 'alias') {
2615          # 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.
2616          # 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.
2617          $retVal = "%%alias=$fid";          # To do the computation, we need to know the favored alias type and the
2618            # feature ID.
2619            my $favored = $cgi->param("FavoredAlias") || "fig";
2620            $retVal = "%%alias=$fid,$favored";
2621      } elsif ($colName eq 'fid') {      } elsif ($colName eq 'fid') {
2622          # 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.
2623          $retVal = HTML::set_prot_links($fid);          $retVal = HTML::set_prot_links($fid);
# Line 2376  Line 2626 
2626          ($retVal) = $record->Value('Feature(assignment)');          ($retVal) = $record->Value('Feature(assignment)');
2627      } elsif ($colName eq 'gblink') {      } elsif ($colName eq 'gblink') {
2628          # 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.
2629          $retVal = Formlet('GBrowse', "GetGBrowse.cgi", undef,          $retVal = FakeButton('GBrowse', "GetGBrowse.cgi", undef,
2630                            fid => $fid);                            fid => $fid);
2631      } elsif ($colName eq 'group') {      } elsif ($colName eq 'group') {
2632          # Get the NMPDR group name.          # Get the NMPDR group name.
# Line 2394  Line 2644 
2644          $retVal = $self->FeatureName($fid);          $retVal = $self->FeatureName($fid);
2645      } elsif ($colName eq 'protlink') {      } elsif ($colName eq 'protlink') {
2646          # Here we want a link to the protein page using the official NMPDR button.          # Here we want a link to the protein page using the official NMPDR button.
2647          $retVal = Formlet('NMPDR', "protein.cgi", undef,          $retVal = FakeButton('NMPDR', "protein.cgi", undef,
2648                            prot => $fid, SPROUT => 1, new_framework => 0,                            prot => $fid, SPROUT => 1, new_framework => 0,
2649                            user => '');                            user => '');
2650        } elsif ($colName eq 'viewerlink') {
2651            # Here we want a link to the SEED viewer page using the official viewer button.
2652            $retVal = FakeButton('Annotation', "index.cgi", undef,
2653                                 action => 'ShowAnnotation', prot => $fid);
2654      }elsif ($colName eq 'subsystem') {      }elsif ($colName eq 'subsystem') {
2655          # Another run-time column: subsystem list.          # Another run-time column: subsystem list.
2656          $retVal = "%%subsystem=$fid";          $retVal = "%%subsystem=$fid";
2657        } elsif ($colName eq 'pdb') {
2658            $retVal = "%%pdb=$fid";
2659      }      }
2660      # Return the result.      # Return the result.
2661      return $retVal;      return $retVal;
# Line 2442  Line 2698 
2698      # Separate the text into a type and data.      # Separate the text into a type and data.
2699      if ($type eq 'alias') {      if ($type eq 'alias') {
2700          # Here the caller wants external alias links for a feature. The text          # Here the caller wants external alias links for a feature. The text
2701          # is the feature ID.          # parameter for computing the alias is the feature ID followed by
2702          my $fid = $text;          # the favored alias type.
2703          # The complicated part is we have to hyperlink them. First, get the          my ($fid, $favored) = split /\s*,\s*/, $text;
2704          # aliases.          # The complicated part is we have to hyperlink them and handle the
2705            # favorites. First, get the aliases.
2706          Trace("Generating aliases for feature $fid.") if T(4);          Trace("Generating aliases for feature $fid.") if T(4);
2707          my @aliases = $sprout->FeatureAliases($fid);          my @aliases = sort $sprout->FeatureAliases($fid);
2708          # Only proceed if we found some.          # Only proceed if we found some.
2709          if (@aliases) {          if (@aliases) {
2710              # Join the aliases into a comma-delimited list.              # Split the aliases into favored and unfavored.
2711              my $aliasList = join(", ", @aliases);              my @favored = ();
2712                my @unfavored = ();
2713                for my $alias (@aliases) {
2714                    # Use substr instead of pattern match because $favored is specified by the user
2715                    # and we don't want him to put funny meta-characters in there.
2716                    if (substr($alias, 0, length($favored)) eq $favored) {
2717                        push @favored, $alias;
2718                    } else {
2719                        push @unfavored, $alias;
2720                    }
2721                }
2722                # Rejoin the aliases into a comma-delimited list, with the favored ones first.
2723                my $aliasList = join(", ", @favored, @unfavored);
2724              # Ask the HTML processor to hyperlink them.              # Ask the HTML processor to hyperlink them.
2725              $retVal = HTML::set_prot_links($cgi, $aliasList);              $retVal = HTML::set_prot_links($cgi, $aliasList);
2726          }          }
# Line 2478  Line 2747 
2747                                        "Feature($keywordName)");                                        "Feature($keywordName)");
2748          # String them into a list.          # String them into a list.
2749          $retVal = join(", ", @values);          $retVal = join(", ", @values);
2750        } elsif ($type eq 'pdb') {
2751            # Here the caller wants the best PDB match to this feature. The text
2752            # is the feature ID. We will display the PDB with a link to the
2753            # PDB page along with the match score. If there are docking results we
2754            # will display a link to the docking result search.
2755            my $fid = $text;
2756            # Ask for the best PDB.
2757            my ($bestPDB) = $sprout->GetAll(['IsProteinForFeature', 'PDB'],
2758                                            "IsProteinForFeature(from-link) = ? ORDER BY IsProteinForFeature(score) LIMIT 1",
2759                                            [$fid], ['PDB(id)', 'PDB(docking-count)', 'IsProteinForFeature(score)']);
2760            # Only proceed if there is a PDB.
2761            if ($bestPDB) {
2762                my ($pdbID, $dockingCount, $score) = @{$bestPDB};
2763                # Convert the PDB ID to a hyperlink.
2764                my $pdbLink = SHDrugSearch::PDBLink($cgi, $pdbID);
2765                # Append the score.
2766                $retVal = "$pdbLink ($score)";
2767                # If there are docking results, append a docking results link.
2768                if ($dockingCount > 0) {
2769                    my $dockString = "$dockingCount docking results";
2770                    my $dockLink = $cgi->a({ href =>  $cgi->url() . "?Class=DrugSearch;PDB=$pdbID;NoForm=1",
2771                                             alt =>   "View computed docking results for $pdbID",
2772                                             title => "View computed docking results for $pdbID",
2773                                             target => "_blank"},
2774                                           $dockString);
2775                }
2776            }
2777      }      }
2778      # Return the result.      # Return the result.
2779      return $retVal;      return $retVal;
# Line 2485  Line 2781 
2781    
2782  =head3 SaveOrganismData  =head3 SaveOrganismData
2783    
2784  C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain); >>  C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain, $taxonomy); >>
2785    
2786  Format the name of an organism and the display version of its group name. The incoming  Format the name of an organism and the display version of its group name. The incoming
2787  data should be the relevant fields from the B<Genome> record in the database. The  data should be the relevant fields from the B<Genome> record in the database. The
# Line 2515  Line 2811 
2811    
2812  Strain of the species represented by the genome.  Strain of the species represented by the genome.
2813    
2814    =item taxonomy
2815    
2816    Taxonomy of the species represented by the genome.
2817    
2818  =item RETURN  =item RETURN
2819    
2820  Returns a two-element list. The first element is the formatted genome name. The second  Returns a three-element list. The first element is the formatted genome name. The second
2821  element is the display name of the genome's group.  element is the display name of the genome's group. The third is the genome's domain.
2822    
2823  =back  =back
2824    
# Line 2526  Line 2826 
2826    
2827  sub SaveOrganismData {  sub SaveOrganismData {
2828      # Get the parameters.      # Get the parameters.
2829      my ($self, $group, $genomeID, $genus, $species, $strain) = @_;      my ($self, $group, $genomeID, $genus, $species, $strain, $taxonomy) = @_;
2830      # Declare the return values.      # Declare the return values.
2831      my ($name, $displayGroup);      my ($name, $displayGroup);
2832      # If the organism does not exist, format an unknown name and a blank group.      # If the organism does not exist, format an unknown name and a blank group.
# Line 2543  Line 2843 
2843          # name unless it's the supporting group, which is nulled out.          # name unless it's the supporting group, which is nulled out.
2844          $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);          $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2845      }      }
2846        # Compute the domain from the taxonomy.
2847        my ($domain) = split /\s*;\s*/, $taxonomy, 2;
2848      # Cache the group and organism data.      # Cache the group and organism data.
2849      my $cache = $self->{orgs};      my $cache = $self->{orgs};
2850      $cache->{$genomeID} = [$name, $displayGroup];      $cache->{$genomeID} = [$name, $displayGroup, $domain];
2851      # Return the result.      # Return the result.
2852      return ($name, $displayGroup);      return ($name, $displayGroup, $domain);
2853  }  }
2854    
2855  =head3 ValidateKeywords  =head3 ValidateKeywords
# Line 2588  Line 2890 
2890      if (! @wordList) {      if (! @wordList) {
2891          if ($required) {          if ($required) {
2892              $self->SetMessage("No search words specified.");              $self->SetMessage("No search words specified.");
2893            } else {
2894                $retVal = 1;
2895          }          }
2896      } elsif (! @plusWords) {      } elsif (! @plusWords) {
2897          $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");          $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
# Line 2598  Line 2902 
2902      return $retVal;      return $retVal;
2903  }  }
2904    
2905    =head3 FakeButton
2906    
2907    C<< my $html = SearchHelper::FakeButton($caption, $url, $target, %parms); >>
2908    
2909    Create a fake button that hyperlinks to the specified URL with the specified parameters.
2910    Unlike a real button, this one won't visibly click, but it will take the user to the
2911    correct place.
2912    
2913    The parameters of this method are deliberately identical to L</Formlet> so that we
2914    can switch easily from real buttons to fake ones in the code.
2915    
2916    =over 4
2917    
2918    =item caption
2919    
2920    Caption to be put on the button.
2921    
2922    =item url
2923    
2924    URL for the target page or script.
2925    
2926    =item target
2927    
2928    Frame or target in which the new page should appear. If C<undef> is specified,
2929    the default target will be used.
2930    
2931    =item parms
2932    
2933    Hash containing the parameter names as keys and the parameter values as values.
2934    These will be appended to the URL.
2935    
2936    =back
2937    
2938    =cut
2939    
2940    sub FakeButton {
2941        # Get the parameters.
2942        my ($caption, $url, $target, %parms) = @_;
2943        # Declare the return variable.
2944        my $retVal;
2945        # Compute the target URL.
2946        my $targetUrl = "$url?" . join(";", map { "$_=" . uri_escape($parms{$_}) } keys %parms);
2947        # Compute the target-frame HTML.
2948        my $targetHtml = ($target ? " target=\"$target\"" : "");
2949        # Assemble the result.
2950        return "<a href=\"$targetUrl\" $targetHtml><div class=\"button2 button\">$caption</div></a>";
2951    }
2952    
2953  =head3 Formlet  =head3 Formlet
2954    
2955  C<< my $html = SearchHelper::Formlet($caption, $url, $target, %parms); >>  C<< my $html = SearchHelper::Formlet($caption, $url, $target, %parms); >>
# Line 2651  Line 3003 
3003      return $retVal;      return $retVal;
3004  }  }
3005    
3006    =head3 TuningParameters
3007    
3008    C<< my $options = $shelp->TuningParameters(%parmHash); >>
3009    
3010    Retrieve tuning parameters from the CGI query object. The parameter is a hash that maps parameter names
3011    to their default values. The parameters and their values will be returned as a hash reference.
3012    
3013    =over 4
3014    
3015    =item parmHash
3016    
3017    Hash mapping parameter names to their default values.
3018    
3019    =item RETURN
3020    
3021    Returns a reference to a hash containing the parameter names mapped to their actual values.
3022    
3023    =back
3024    
3025    =cut
3026    
3027    sub TuningParameters {
3028        # Get the parameters.
3029        my ($self, %parmHash) = @_;
3030        # Declare the return variable.
3031        my $retVal = {};
3032        # Get the CGI Query Object.
3033        my $cgi = $self->Q();
3034        # Loop through the parameter names.
3035        for my $parm (keys %parmHash) {
3036            # Get the incoming value for this parameter.
3037            my $value = $cgi->param($parm);
3038            # Zero might be a valid value, so we do an is-defined check rather than an OR.
3039            if (defined($value)) {
3040                $retVal->{$parm} = $value;
3041            } else {
3042                $retVal->{$parm} = $parmHash{$parm};
3043            }
3044        }
3045        # Return the result.
3046        return $retVal;
3047    }
3048    
3049  =head2 Virtual Methods  =head2 Virtual Methods
3050    
3051  =head3 Form  =head3 Form
# Line 2714  Line 3109 
3109      return $retVal;      return $retVal;
3110  }  }
3111    
3112    =head3 SearchTitle
3113    
3114    C<< my $titleHtml = $shelp->SearchTitle(); >>
3115    
3116    Return the display title for this search. The display title appears above the search results.
3117    If no result is returned, no title will be displayed. The result should be an html string
3118    that can be legally put inside a block tag such as C<h3> or C<p>.
3119    
3120    =cut
3121    
3122    sub SearchTitle {
3123        # Get the parameters.
3124        my ($self) = @_;
3125        # Declare the return variable.
3126        my $retVal;
3127        # Return it.
3128        return $retVal;
3129    }
3130    
3131    =head3 DownloadFormatAvailable
3132    
3133    C<< my $okFlag = $shelp->DownloadFormatAvailable($format); >>
3134    
3135    This method returns TRUE if a specified download format is legal for this type of search
3136    and FALSE otherwise. For any feature-based search, there is no need to override this
3137    method.
3138    
3139    =over 4
3140    
3141    =item format
3142    
3143    Download format type code.
3144    
3145    =item RETURN
3146    
3147    Returns TRUE if the download format is legal for this search and FALSE otherwise.
3148    
3149    =back
3150    
3151    =cut
3152    
3153    sub DownloadFormatAvailable {
3154        # Get the parameters.
3155        my ($self, $format) = @_;
3156        # Declare the return variable.
3157        my $retVal = 1;
3158        # Return the result.
3159        return $retVal;
3160    }
3161    
3162    =head3 ColumnTitle
3163    
3164    C<< my $title = $shelp->ColumnTitle($colName); >>
3165    
3166    Return the column heading title to be used for the specified column name. The
3167    default implementation is to simply call L</FeatureColumnTitle>.
3168    
3169    =over 4
3170    
3171    =item colName
3172    
3173    Name of the desired column.
3174    
3175    =item RETURN
3176    
3177    Returns the title to be used as the column header for the named column.
3178    
3179    =back
3180    
3181    =cut
3182    
3183    sub ColumnTitle {
3184        my ($self, $colName) = @_;
3185        return $self->FeatureColumnTitle($colName);
3186    }
3187    
3188    
3189  1;  1;

Legend:
Removed from v.1.19  
changed lines
  Added in v.1.32

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3