[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.9, Sat Oct 7 13:18:11 2006 UTC revision 1.27, Wed Feb 21 13:18:27 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    C<0> if the extra columns are to be at the beginning, else C<1>. The
94    default is zero; use the L</SetExtraPos> method to change this option.
95    
96  =back  =back
97    
98  =head2 Adding a new Search Tool  =head2 Adding a new Search Tool
# Line 113  Line 118 
118    
119  =item 4  =item 4
120    
121  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.  
122    
123  =back  =back
124    
# Line 177  Line 181 
181    
182  =back  =back
183    
184    If you are doing a feature search, you can also change the list of feature
185    columns displayed and their display order by overriding
186    L</DefaultFeatureColumns>.
187    
188  Finally, when generating the code for your controls, be sure to use any incoming  Finally, when generating the code for your controls, be sure to use any incoming
189  query parameters as default values so that the search request is persistent.  query parameters as default values so that the search request is persistent.
190    
# Line 222  Line 230 
230      }      }
231    
232  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
233  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
234  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
235  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
236  above code is just a loose framework.  above code is just a loose framework.
# Line 241  Line 249 
249    
250  # 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.
251  my $formCount = 0;  my $formCount = 0;
252    # This counter is used to generate unique DIV IDs.
253    my $divCount = 0;
254    
255  =head2 Public Methods  =head2 Public Methods
256    
# Line 252  Line 262 
262    
263  =over 4  =over 4
264    
265  =item query  =item cgi
266    
267  The CGI query object for the current script.  The CGI query object for the current script.
268    
# Line 262  Line 272 
272    
273  sub new {  sub new {
274      # Get the parameters.      # Get the parameters.
275      my ($class, $query) = @_;      my ($class, $cgi) = @_;
276      # Check for a session ID.      # Check for a session ID.
277      my $session_id = $query->param("SessionID");      my $session_id = $cgi->param("SessionID");
278      my $type = "old";      my $type = "old";
279      if (! $session_id) {      if (! $session_id) {
280            Trace("No session ID found.") if T(3);
281          # 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
282          # store it in the query object.          # store it in the query object.
283          $session_id = NewSessionID();          $session_id = NewSessionID();
284          $type = "new";          $type = "new";
285          $query->param(-name => 'SessionID', -value => $session_id);          $cgi->param(-name => 'SessionID', -value => $session_id);
286        } else {
287            Trace("Session ID is $session_id.") if T(3);
288      }      }
289      # Compute the subclass name.      # Compute the subclass name.
290      $class =~ /SH(.+)$/;      my $subClass;
291      my $subClass = $1;      if ($class =~ /SH(.+)$/) {
292            # Here we have a real search class.
293            $subClass = $1;
294        } else {
295            # Here we have a bare class. The bare class cannot search, but it can
296            # process search results.
297            $subClass = 'SearchHelper';
298        }
299      # Insure everybody knows we're in Sprout mode.      # Insure everybody knows we're in Sprout mode.
300      $query->param(-name => 'SPROUT', -value => 1);      $cgi->param(-name => 'SPROUT', -value => 1);
301      # Generate the form name.      # Generate the form name.
302      my $formName = "$class$formCount";      my $formName = "$class$formCount";
303      $formCount++;      $formCount++;
# Line 285  Line 305 
305      # 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
306      # class name and a placeholder for the Sprout object.      # class name and a placeholder for the Sprout object.
307      my $retVal = {      my $retVal = {
308                    query => $query,                    query => $cgi,
309                    type => $type,                    type => $type,
310                    class => $subClass,                    class => $subClass,
311                    sprout => undef,                    sprout => undef,
# Line 295  Line 315 
315                    genomeList => undef,                    genomeList => undef,
316                    genomeParms => [],                    genomeParms => [],
317                    filtered => 0,                    filtered => 0,
318                      extraPos => 0,
319                   };                   };
320      # Bless and return it.      # Bless and return it.
321      bless $retVal, $class;      bless $retVal, $class;
# Line 355  Line 376 
376      return ($self->{type} eq 'new');      return ($self->{type} eq 'new');
377  }  }
378    
379    =head3 SetExtraPos
380    
381    C<< $shelp->SetExtraPos($newValue); >>
382    
383    Indicate whether the extra columns should be in the front (C<0>) or end (C<1>) columns of the results.
384    
385    =over 4
386    
387    =item newValue
388    
389    C<1> if the extra columns should be displayed at the end, else C<0>.
390    
391    =back
392    
393    =cut
394    
395    sub SetExtraPos {
396        my ($self, $newValue) = @_;
397        $self->{extraPos} = $newValue;
398    }
399    
400  =head3 ID  =head3 ID
401    
402  C<< my $sessionID = $shelp->ID(); >>  C<< my $sessionID = $shelp->ID(); >>
# Line 449  Line 491 
491      my ($self, $title) = @_;      my ($self, $title) = @_;
492      # Get the CGI object.      # Get the CGI object.
493      my $cgi = $self->Q();      my $cgi = $self->Q();
494      # Start the form.      # Start the form. Note we use the override option on the Class value, in
495        # case the Advanced button was used.
496      my $retVal = "<div class=\"search\">\n" .      my $retVal = "<div class=\"search\">\n" .
497                   $cgi->start_form(-method => 'POST',                   $cgi->start_form(-method => 'POST',
498                                    -action => $cgi->url(-relative => 1),                                    -action => $cgi->url(-relative => 1),
499                                    -name => $self->FormName()) .                                    -name => $self->FormName()) .
500                   $cgi->hidden(-name => 'Class',                   $cgi->hidden(-name => 'Class',
501                                -value => $self->{class}) .                                -value => $self->{class},
502                                  -override => 1) .
503                   $cgi->hidden(-name => 'SPROUT',                   $cgi->hidden(-name => 'SPROUT',
504                                -value => 1) .                                -value => 1) .
505                   $cgi->h3($title);                   $cgi->h3($title);
# Line 609  Line 653 
653    
654  =head3 PutFeature  =head3 PutFeature
655    
656  C<< $shelp->PutFeature($fquery); >>  C<< $shelp->PutFeature($fdata); >>
657    
658  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
659  searches, since the primary data item in the database is features.  searches, since the primary data item in the database is features.
# Line 620  Line 664 
664  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
665  code adds columns for essentiality and virulence.  code adds columns for essentiality and virulence.
666    
667      $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);      $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
668      $shelp->PutFeature($fq);      $shelp->PutFeature($fd);
669    
670  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
671  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 631  Line 675 
675      if (! $essentialFlag) {      if (! $essentialFlag) {
676          $essentialFlag = undef;          $essentialFlag = undef;
677      }      }
678      $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);      $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
679      $shelp->PutFeature($fq);      $shelp->PutFeature($fd);
680    
681  =over 4  =over 4
682    
683  =item fquery  =item fdata
684    
685  FeatureQuery object containing the current feature data.  B<FeatureData> object containing the current feature data.
686    
687  =back  =back
688    
# Line 646  Line 690 
690    
691  sub PutFeature {  sub PutFeature {
692      # Get the parameters.      # Get the parameters.
693      my ($self, $fq) = @_;      my ($self, $fd) = @_;
694      # Get the CGI query object.      # Get the CGI query object.
695      my $cgi = $self->Q();      my $cgi = $self->Q();
696      # Get the feature data.      # Get the feature data.
697      my $record = $fq->Feature();      my $record = $fd->Feature();
698      my $extraCols = $fq->ExtraCols();      my $extraCols = $fd->ExtraCols();
699      # Check for a first-call situation.      # Check for a first-call situation.
700      if (! defined $self->{cols}) {      if (! defined $self->{cols}) {
701          # Here we need to set up the column information. Start with the defaults.          Trace("Setting up the columns.") if T(3);
702          $self->{cols} = $self->DefaultFeatureColumns();          # Here we need to set up the column information. First we accumulate the extras,
703          # Add the externals if they were requested.          # sorted by column name.
704          if ($cgi->param('ShowAliases')) {          my @xtraNames = ();
             push @{$self->{cols}}, 'alias';  
         }  
         # Append the extras, sorted by column name.  
705          for my $col (sort keys %{$extraCols}) {          for my $col (sort keys %{$extraCols}) {
706              push @{$self->{cols}}, "X=$col";              push @xtraNames, "X=$col";
707          }          }
708            # Set up the column name array.
709            my @colNames = ();
710            # If extras go at the beginning, put them in first.
711            if (! $self->{extraPos}) {
712                push @colNames, @xtraNames;
713            }
714            # Add the default columns.
715            push @colNames, $self->DefaultFeatureColumns();
716            # Add any additional columns requested by the feature filter.
717            push @colNames, FeatureQuery::AdditionalColumns($self);
718            # If extras go at the end, put them in here.
719            if ($self->{extraPos}) {
720                push @colNames, @xtraNames;
721            }
722            Trace("Full column list determined.") if T(3);
723            # Save the full list.
724            $self->{cols} = \@colNames;
725          # 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
726          # output.          # output.
727            Trace("Writing column headers.") if T(3);
728          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});
729            Trace("Column headers written.") if T(3);
730      }      }
731      # Get the feature ID.      # Get the feature ID.
732      my ($fid) = $record->Value('Feature(id)');      my $fid = $fd->FID();
733      # Loop through the column headers, producing the desired data.      # Loop through the column headers, producing the desired data.
734      my @output = ();      my @output = ();
735      for my $colName (@{$self->{cols}}) {      for my $colName (@{$self->{cols}}) {
# Line 677  Line 737 
737      }      }
738      # Compute the sort key. The sort key usually floats NMPDR organism features to the      # Compute the sort key. The sort key usually floats NMPDR organism features to the
739      # top of the return list.      # top of the return list.
740      my $key = $self->SortKey($record);      my $key = $self->SortKey($fd);
741      # Write the feature data.      # Write the feature data.
742      $self->WriteColumnData($key, @output);      $self->WriteColumnData($key, @output);
743  }  }
# Line 826  Line 886 
886                                                      ['Genome(genus)', 'Genome(species)',                                                      ['Genome(genus)', 'Genome(species)',
887                                                       'Genome(unique-characterization)',                                                       'Genome(unique-characterization)',
888                                                       'Genome(primary-group)']);                                                       'Genome(primary-group)']);
889          # Null out the supporting group.          # Format and cache the name and display group.
890          $group = "" if ($group eq $FIG_Config::otherGroup);          ($orgName, $group) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
891          # 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];  
892      }      }
893      # Return the result.      # Return the result.
894      return ($orgName, $group);      return ($orgName, $group);
# Line 950  Line 999 
999    
1000  =head3 ComputeFASTA  =head3 ComputeFASTA
1001    
1002  C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >>  C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence); >>
1003    
1004  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.  
1005    
1006  =over 4  =over 4
1007    
 =item incomingType  
   
 C<dna> if this is a DNA sequence, C<prot> if this is a protein sequence.  
   
1008  =item desiredType  =item desiredType
1009    
1010  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.  
1011    
1012  =item sequence  =item sequence
1013    
# Line 987  Line 1029 
1029    
1030  sub ComputeFASTA {  sub ComputeFASTA {
1031      # Get the parameters.      # Get the parameters.
1032      my ($self, $incomingType, $desiredType, $sequence) = @_;      my ($self, $desiredType, $sequence) = @_;
1033      # Declare the return variable. If an error occurs, it will remain undefined.      # Declare the return variable. If an error occurs, it will remain undefined.
1034      my $retVal;      my $retVal;
1035        # This variable will be cleared if an error is detected.
1036        my $okFlag = 1;
1037      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
1038      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
1039        Trace("FASTA desired type is $desiredType.") if T(4);
1040      # Check for a feature specification.      # Check for a feature specification.
1041      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
1042          # 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
1043          # it.          # it.
1044          my $fid = $1;          my $fid = $1;
1045            Trace("Feature ID for fasta is $fid.") if T(3);
1046          my $sprout = $self->DB();          my $sprout = $self->DB();
1047          # 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
1048          # 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
1049          # exist.          # exist.
1050          my ($figID) = $sprout->FeaturesByAlias($fid);          my ($figID) = $sprout->FeaturesByAlias($fid);
1051          if (! $figID) {          if (! $figID) {
1052              $self->SetMessage("No feature found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
1053                $okFlag = 0;
1054          } else {          } else {
1055              # Set the FASTA label.              # Set the FASTA label.
1056              my $fastaLabel = $fid;              my $fastaLabel = $fid;
1057              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
1058              if ($desiredType =~ /prot/i) {              if ($desiredType eq 'prot') {
1059                  # We want protein, so get the translation.                  # We want protein, so get the translation.
1060                  $fastaData = $sprout->FeatureTranslation($figID);                  $fastaData = $sprout->FeatureTranslation($figID);
1061                    Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
1062              } else {              } else {
1063                  # 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.
1064                  my @locList = $sprout->FeatureLocation($figID);                  my @locList = $sprout->FeatureLocation($figID);
1065                  $fastaData = $sprout->DNASeq(\@locList);                  $fastaData = $sprout->DNASeq(\@locList);
1066                    Trace(length $fastaData . " characters returned for DNA of $fastaLabel.") if T(3);
1067              }              }
1068          }          }
     } elsif ($incomingType =~ /prot/ && $desiredType =~ /dna/) {  
         # Here we're being asked to do an impossible conversion.  
         $self->SetMessage("Cannot convert a protein sequence to DNA.");  
1069      } else {      } else {
1070            Trace("Analyzing FASTA sequence.") if T(4);
1071          # 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.
1072          if ($sequence =~ /^>\s*(\S.*)\s*\n(.+)$/) {          if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) {
1073                Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4);
1074              # Here we have a label, so we split it from the data.              # Here we have a label, so we split it from the data.
1075              $fastaLabel = $1;              $fastaLabel = $1;
1076              $fastaData = $2;              $fastaData = $2;
1077          } else {          } else {
1078                Trace("No label found in match to sequence:\n$sequence") if T(4);
1079              # 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
1080              # as data.              # as data.
1081              $fastaLabel = "User-specified $incomingType sequence";              $fastaLabel = "User-specified $desiredType sequence";
1082              $fastaData = $sequence;              $fastaData = $sequence;
1083          }          }
1084          # The next step is to clean the junk out of the sequence.          # The next step is to clean the junk out of the sequence.
1085          $fastaData =~ s/\n//g;          $fastaData =~ s/\n//g;
1086          $fastaData =~ s/\s+//g;          $fastaData =~ s/\s+//g;
1087          # 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.
1088          # we've already prevented a conversion from protein to DNA.          if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn]/i) {
1089          if ($incomingType ne $desiredType) {              $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?");
1090              $fastaData = Sprout::Protein($fastaData);              $okFlag = 0;
1091          }          }
1092      }      }
1093      # At this point, either "$fastaLabel" and "$fastaData" have values or an error is      Trace("FASTA data sequence: $fastaData") if T(4);
1094      # in progress.      # Only proceed if no error was detected.
1095      if (defined $fastaLabel) {      if ($okFlag) {
1096          # 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
1097          # grep-split trick. The split, because of the presence of the parentheses,          # grep-split trick. The split, because of the presence of the parentheses,
1098          # includes the matched delimiters in the output list. The grep strips out          # includes the matched delimiters in the output list. The grep strips out
1099          # the empty list items that appear between the so-called delimiters, since          # the empty list items that appear between the so-called delimiters, since
1100          # the delimiters are what we want.          # the delimiters are what we want.
1101          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
1102          my $retVal = join("\n", ">$fastaLabel", @chunks, "");          $retVal = join("\n", ">$fastaLabel", @chunks, "");
1103      }      }
1104      # Return the result.      # Return the result.
1105      return $retVal;      return $retVal;
1106  }  }
1107    
1108    =head3 SubsystemTree
1109    
1110    C<< my $tree = SearchHelper::SubsystemTree($sprout, %options); >>
1111    
1112    This method creates a subsystem selection tree suitable for passing to
1113    L</SelectionTree>. Each leaf node in the tree will have a link to the
1114    subsystem display page. In addition, each node can have a radio button. The
1115    radio button alue is either C<classification=>I<string>, where I<string> is
1116    a classification string, or C<id=>I<string>, where I<string> is a subsystem ID.
1117    Thus, it can either be used to filter by a group of related subsystems or a
1118    single subsystem.
1119    
1120    =over 4
1121    
1122    =item sprout
1123    
1124    Sprout database object used to get the list of subsystems.
1125    
1126    =item options
1127    
1128    Hash containing options for building the tree.
1129    
1130    =item RETURN
1131    
1132    Returns a reference to a tree list suitable for passing to L</SelectionTree>.
1133    
1134    =back
1135    
1136    The supported options are as follows.
1137    
1138    =over 4
1139    
1140    =item radio
1141    
1142    TRUE if the tree should be configured for radio buttons. The default is FALSE.
1143    
1144    =item links
1145    
1146    TRUE if the tree should be configured for links. The default is TRUE.
1147    
1148    =back
1149    
1150    =cut
1151    
1152    sub SubsystemTree {
1153        # Get the parameters.
1154        my ($sprout, %options) = @_;
1155        # Process the options.
1156        my $optionThing = Tracer::GetOptions({ radio => 0, links => 1 }, \%options);
1157        # Read in the subsystems.
1158        my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1159                                   ['Subsystem(classification)', 'Subsystem(id)']);
1160        # Put any unclassified subsystems at the end. They will always be at the beginning, so if one
1161        # is at the end, ALL subsystems are unclassified and we don't bother.
1162        if ($#subs >= 0 && $subs[$#subs]->[0] ne '') {
1163            while ($subs[0]->[0] eq '') {
1164                my $classLess = shift @subs;
1165                push @subs, $classLess;
1166            }
1167        }
1168        # Declare the return variable.
1169        my @retVal = ();
1170        # Each element in @subs represents a leaf node, so as we loop through it we will be
1171        # producing one leaf node at a time. The leaf node is represented as a 2-tuple. The
1172        # first element is a semi-colon-delimited list of the classifications for the
1173        # subsystem. There will be a stack of currently-active classifications, which we will
1174        # compare to the incoming classifications from the end backward. A new classification
1175        # requires starting a new branch. A different classification requires closing an old
1176        # branch and starting a new one. Each classification in the stack will also contain
1177        # that classification's current branch. We'll add a fake classification at the
1178        # beginning that we can use to represent the tree as a whole.
1179        my $rootName = '<root>';
1180        # Create the classification stack. Note the stack is a pair of parallel lists,
1181        # one containing names and the other containing content.
1182        my @stackNames = ($rootName);
1183        my @stackContents = (\@retVal);
1184        # Add a null entry at the end of the subsystem list to force an unrolling.
1185        push @subs, ['', undef];
1186        # Loop through the subsystems.
1187        for my $sub (@subs) {
1188            # Pull out the classification list and the subsystem ID.
1189            my ($classString, $id) = @{$sub};
1190            Trace("Processing class \"$classString\" and subsystem $id.") if T(4);
1191            # Convert the classification string to a list with the root classification in
1192            # the front.
1193            my @classList = ($rootName, split($FIG_Config::splitter, $classString));
1194            # Find the leftmost point at which the class list differs from the stack.
1195            my $matchPoint = 0;
1196            while ($matchPoint <= $#stackNames && $matchPoint <= $#classList &&
1197                   $stackNames[$matchPoint] eq $classList[$matchPoint]) {
1198                $matchPoint++;
1199            }
1200            Trace("Match point is $matchPoint. Stack length is " . scalar(@stackNames) .
1201                  ". Class List length is " . scalar(@classList) . ".") if T(4);
1202            # Unroll the stack to the matchpoint.
1203            while ($#stackNames >= $matchPoint) {
1204                my $popped = pop @stackNames;
1205                pop @stackContents;
1206                Trace("\"$popped\" popped from stack.") if T(4);
1207            }
1208            # Start branches for any new classifications.
1209            while ($#stackNames < $#classList) {
1210                # The branch for a new classification contains its radio button
1211                # data and then a list of children. So, at this point, if radio buttons
1212                # are desired, we put them into the content.
1213                my $newLevel = scalar(@stackNames);
1214                my @newClassContent = ();
1215                if ($optionThing->{radio}) {
1216                    my $newClassString = join($FIG_Config::splitter, @classList[1..$newLevel]);
1217                    push @newClassContent, { value => "classification=$newClassString%" };
1218                }
1219                # The new classification node is appended to its parent's content
1220                # and then pushed onto the stack. First, we need the node name.
1221                my $nodeName = $classList[$newLevel];
1222                # Add the classification to its parent. This makes it part of the
1223                # tree we'll be returning to the user.
1224                push @{$stackContents[$#stackNames]}, $nodeName, \@newClassContent;
1225                # Push the classification onto the stack.
1226                push @stackContents, \@newClassContent;
1227                push @stackNames, $nodeName;
1228                Trace("\"$nodeName\" pushed onto stack.") if T(4);
1229            }
1230            # Now the stack contains all our parent branches. We add the subsystem to
1231            # the branch at the top of the stack, but only if it's NOT the dummy node.
1232            if (defined $id) {
1233                # Compute the node name from the ID.
1234                my $nodeName = $id;
1235                $nodeName =~ s/_/ /g;
1236                # Create the node's leaf hash. This depends on the value of the radio
1237                # and link options.
1238                my $nodeContent = {};
1239                if ($optionThing->{links}) {
1240                    # Compute the link value.
1241                    my $linkable = uri_escape($id);
1242                    $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;SPROUT=1";
1243                }
1244                if ($optionThing->{radio}) {
1245                    # Compute the radio value.
1246                    $nodeContent->{value} = "id=$id";
1247                }
1248                # Push the node into its parent branch.
1249                Trace("\"$nodeName\" added to node list.") if T(4);
1250                push @{$stackContents[$#stackNames]}, $nodeName, $nodeContent;
1251            }
1252        }
1253        # Return the result.
1254        return \@retVal;
1255    }
1256    
1257    
1258  =head3 NmpdrGenomeMenu  =head3 NmpdrGenomeMenu
1259    
1260  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>
# Line 1136  Line 1335 
1335          for my $genome (@genomeList) {          for my $genome (@genomeList) {
1336              # Get the genome data.              # Get the genome data.
1337              my ($group, $genomeID, $genus, $species, $strain) = @{$genome};              my ($group, $genomeID, $genus, $species, $strain) = @{$genome};
1338              # Form the genome name.              # Compute and cache its name and display group.
1339              my $name = "$genus $species";              my ($name, $displayGroup) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1340              if ($strain) {                                                                  $strain);
1341                  $name .= " $strain";              # Push the genome into the group's list. Note that we use the real group
1342              }              # name here, not the display group name.
             # Push the genome into the group's list.  
1343              push @{$gHash{$group}}, [$genomeID, $name];              push @{$gHash{$group}}, [$genomeID, $name];
1344          }          }
1345          # Save the genome list for future use.          # Save the genome list for future use.
# Line 1158  Line 1356 
1356      if (defined $selected) {      if (defined $selected) {
1357          %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};          %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};
1358      }      }
1359      # 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
1360        # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes
1361        # and use that to make the selections.
1362        my $nmpdrCount = 0;
1363      # Create the type counters.      # Create the type counters.
1364      my $groupCount = 1;      my $groupCount = 1;
1365      # Compute the ID for the status display.      # Compute the ID for the status display.
# Line 1168  Line 1369 
1369      # If multiple selection is supported, create an onChange event.      # If multiple selection is supported, create an onChange event.
1370      my $onChange = "";      my $onChange = "";
1371      if ($cross) {      if ($cross) {
1372            # Here we have a paired menu. Selecting something in our menu unselects it in the
1373            # other and redisplays the status of both.
1374          $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";          $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";
1375      } elsif ($multiple) {      } elsif ($multiple) {
1376            # This is an unpaired menu, so all we do is redisplay our status.
1377          $onChange = " onChange=\"$showSelect\"";          $onChange = " onChange=\"$showSelect\"";
1378      }      }
1379      # Create the SELECT tag and stuff it into the output array.      # Create the SELECT tag and stuff it into the output array.
1380      my $select = "<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">";      my @lines = ("<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">");
     my @lines = ($select);  
1381      # Loop through the groups.      # Loop through the groups.
1382      for my $group (@groups) {      for my $group (@groups) {
1383          # Create the option group tag.          # Create the option group tag.
1384          my $tag = "<OPTGROUP label=\"$group\">";          my $tag = "<OPTGROUP label=\"$group\">";
1385          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");  
1386          # Get the genomes in the group.          # Get the genomes in the group.
1387          for my $genome (@{$groupHash->{$group}}) {          for my $genome (@{$groupHash->{$group}}) {
1388                # Count this organism if it's NMPDR.
1389                if ($group ne $FIG_Config::otherGroup) {
1390                    $nmpdrCount++;
1391                }
1392                # Get the organism ID and name.
1393              my ($genomeID, $name) = @{$genome};              my ($genomeID, $name) = @{$genome};
1394              # See if it's selected.              # See if it's selected.
1395              my $select = ($selectedHash{$genomeID} ? " selected" : "");              my $select = ($selectedHash{$genomeID} ? " selected" : "");
1396              # Generate the option tag.              # Generate the option tag.
1397              my $optionTag = "<OPTION value=\"$genomeID\" label=\"$label\"$select>$name <em>($genomeID)</em></OPTION>";              my $optionTag = "<OPTION value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";
1398              push @lines, "    $optionTag";              push @lines, "    $optionTag";
1399          }          }
1400          # Close the option group.          # Close the option group.
# Line 1202  Line 1404 
1404      push @lines, "</SELECT>";      push @lines, "</SELECT>";
1405      # Check for multiple selection.      # Check for multiple selection.
1406      if ($multiple) {      if ($multiple) {
1407          # 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
1408          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  
1409          # the text selected automatically.          # the text selected automatically.
1410          my $searchThingName = "${menuName}_SearchThing";          my $searchThingName = "${menuName}_SearchThing";
1411          push @lines, "<br>Select genomes containing <INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />&nbsp;" .          push @lines, "<br />" .
1412                       "<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;" .
1413                         "<INPUT type=\"text\" name=\"$searchThingName\" size=\"30\" />";
1414            # Next are the buttons to set and clear selections.
1415            push @lines, "<br />";
1416            push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";
1417            push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";
1418            push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\"  value=\"Select NMPDR\" onClick=\"selectSome($menuName, $nmpdrCount, true); $showSelect\" />";
1419            push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, $nmpdrCount, false); $showSelect\" />";
1420          # Add the status display, too.          # Add the status display, too.
1421          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";
1422          # 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 1331  Line 1535 
1535    
1536  =head3 SubmitRow  =head3 SubmitRow
1537    
1538  C<< my $htmlText = $shelp->SubmitRow(); >>  C<< my $htmlText = $shelp->SubmitRow($caption); >>
1539    
1540  Returns the HTML text for the row containing the page size control  Returns the HTML text for the row containing the page size control
1541  and the submit button. All searches should have this row somewhere  and the submit button. All searches should have this row somewhere
1542  near the top of the form.  near the top of the form.
1543    
1544    =over 4
1545    
1546    =item caption (optional)
1547    
1548    Caption to be put on the search button. The default is C<Go>.
1549    
1550    =item RETURN
1551    
1552    Returns a table row containing the controls for submitting the search
1553    and tuning the results.
1554    
1555    =back
1556    
1557  =cut  =cut
1558    
1559  sub SubmitRow {  sub SubmitRow {
1560      # Get the parameters.      # Get the parameters.
1561      my ($self) = @_;      my ($self, $caption) = @_;
1562      my $cgi = $self->Q();      my $cgi = $self->Q();
1563        # Compute the button caption.
1564        my $realCaption = (defined $caption ? $caption : 'Go');
1565      # Get the current page size.      # Get the current page size.
1566      my $pageSize = $cgi->param('PageSize');      my $pageSize = $cgi->param('PageSize');
1567      # Get the incoming external-link flag.      # Get the incoming external-link flag.
# Line 1351  Line 1570 
1570      my $retVal = $cgi->Tr($cgi->td("Results/Page"),      my $retVal = $cgi->Tr($cgi->td("Results/Page"),
1571                            $cgi->td($cgi->popup_menu(-name => 'PageSize',                            $cgi->td($cgi->popup_menu(-name => 'PageSize',
1572                                                      -values => [10, 25, 50, 100, 1000],                                                      -values => [10, 25, 50, 100, 1000],
1573                                                      -default => $pageSize) . " " .                                                      -default => $pageSize)),
                                    $cgi->checkbox(-name => 'ShowURL',  
                                                   -value => 1,  
                                                   -label => 'Show URL')),  
1574                            $cgi->td($cgi->submit(-class => 'goButton',                            $cgi->td($cgi->submit(-class => 'goButton',
1575                                                  -name => 'Search',                                                  -name => 'Search',
1576                                                  -value => 'Go')));                                                  -value => $realCaption)));
1577      # Return the result.      # Return the result.
1578      return $retVal;      return $retVal;
1579  }  }
1580    
1581  =head3 FeatureFilterRows  =head3 FeatureFilterRows
1582    
1583  C<< my $htmlText = $shelp->FeatureFilterRows(); >>  C<< my $htmlText = $shelp->FeatureFilterRows(@subset); >>
1584    
1585    This method creates table rows that can be used to filter features. The form
1586    values can be used to select features by genome using the B<FeatureQuery>
1587    object.
1588    
1589    =over 4
1590    
1591    =item subset
1592    
1593    List of rows to display. The default (C<all>) is to display all rows.
1594    C<words> displays the word search box, C<subsys> displays the subsystem
1595    selector, and C<options> displays the options row.
1596    
1597    =item RETURN
1598    
1599    Returns the html text for table rows containing the desired feature filtering controls.
1600    
1601  This method creates table rows that can be used to filter features. There are  =back
 two rows returned, and the values can be used to select features by genome  
 using the B<FeatureQuery> object.  
1602    
1603  =cut  =cut
1604    
1605  sub FeatureFilterRows {  sub FeatureFilterRows {
1606      # Get the parameters.      # Get the parameters.
1607      my ($self) = @_;      my ($self, @subset) = @_;
1608        if (@subset == 0 || $subset[0] eq 'all') {
1609            @subset = qw(words subsys options);
1610        }
1611      # Return the result.      # Return the result.
1612      return FeatureQuery::FilterRows($self);      return FeatureQuery::FilterRows($self, @subset);
1613  }  }
1614    
1615  =head3 GBrowseFeatureURL  =head3 GBrowseFeatureURL
# Line 1451  Line 1684 
1684          $seg_id =~ s/:/--/g;          $seg_id =~ s/:/--/g;
1685          Trace("Show limits are ($show_start,$show_stop) in genome $genomeID with ref $seg_id.") if T(3);          Trace("Show limits are ($show_start,$show_stop) in genome $genomeID with ref $seg_id.") if T(3);
1686          # Assemble all the pieces.          # Assemble all the pieces.
1687          $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";
1688      }      }
1689      # Return the result.      # Return the result.
1690      return $retVal;      return $retVal;
# Line 1544  Line 1777 
1777    
1778  =head3 ComputeSearchURL  =head3 ComputeSearchURL
1779    
1780  C<< my $url = $shelp->ComputeSearchURL(); >>  C<< my $url = $shelp->ComputeSearchURL(%overrides); >>
1781    
1782  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
1783  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 1554  Line 1787 
1787  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
1788  remove the parameter entirely from a get-style URL.  remove the parameter entirely from a get-style URL.
1789    
1790    =over 4
1791    
1792    =item overrides
1793    
1794    Hash containing override values for the parameters, where the parameter name is
1795    the key and the parameter value is the override value. If the override value is
1796    C<undef>, the parameter will be deleted from the result.
1797    
1798    =item RETURN
1799    
1800    Returns a GET-style URL for invoking the search with the specified overrides.
1801    
1802    =back
1803    
1804  =cut  =cut
1805    
1806  sub ComputeSearchURL {  sub ComputeSearchURL {
1807      # Get the parameters.      # Get the parameters.
1808      my ($self) = @_;      my ($self, %overrides) = @_;
1809      # Get the database and CGI query object.      # Get the database and CGI query object.
1810      my $cgi = $self->Q();      my $cgi = $self->Q();
1811      my $sprout = $self->DB();      my $sprout = $self->DB();
# Line 1585  Line 1832 
1832          # a singleton list, but that's okay.          # a singleton list, but that's okay.
1833          my @values = split (/\0/, $parms{$parmKey});          my @values = split (/\0/, $parms{$parmKey});
1834          # Check for special cases.          # Check for special cases.
1835          if ($parmKey eq 'featureTypes') {          if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) {
             # 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)) {  
1836              # These are bookkeeping parameters we don't need to start a search.              # These are bookkeeping parameters we don't need to start a search.
1837              @values = ();              @values = ();
1838          } elsif ($parmKey =~ /_SearchThing$/) {          } elsif ($parmKey =~ /_SearchThing$/) {
# Line 1613  Line 1846 
1846              if ($allFlag) {              if ($allFlag) {
1847                  @values = ();                  @values = ();
1848              }              }
1849            } elsif (exists $overrides{$parmKey}) {
1850                # Here the value is being overridden, so we skip it for now.
1851                @values = ();
1852          }          }
1853          # If we still have values, create the URL parameters.          # If we still have values, create the URL parameters.
1854          if (@values) {          if (@values) {
1855              push @urlList, map { "$parmKey=" . uri_escape($_) } @values;              push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1856          }          }
1857      }      }
1858        # Now do the overrides.
1859        for my $overKey (keys %overrides) {
1860            # Only use this override if it's not a delete marker.
1861            if (defined $overrides{$overKey}) {
1862                push @urlList, "$overKey=" . uri_escape($overrides{$overKey});
1863            }
1864        }
1865      # Add the parameters to the URL.      # Add the parameters to the URL.
1866      $retVal .= "?" . join(";", @urlList);      $retVal .= "?" . join(";", @urlList);
1867      # Return the result.      # Return the result.
# Line 1661  Line 1904 
1904      return $retVal;      return $retVal;
1905  }  }
1906    
1907  =head3 FeatureTypeMap  =head3 AdvancedClassList
1908    
1909  C<< my %features = SearchHelper::FeatureTypeMap(); >>  C<< my @classes = SearchHelper::AdvancedClassList(); >>
1910    
1911  Return a map of feature types to descriptions. The feature type data is stored  Return a list of advanced class names. This list is used to generate the directory
1912  in the B<FIG_Config> file. Currently, it only contains a space-delimited list of  of available searches on the search page.
 feature types. The map returned by this method is a hash mapping the type codes to  
 descriptive names.  
1913    
1914  The reason we have to convert the list from a string is that the B<NMPDRSetup.pl>  We use the %INC variable to accomplish this.
 script is only able to insert strings into the generated B<FIG_Config> file.  
1915    
1916  =cut  =cut
1917    
1918  sub FeatureTypeMap {  sub AdvancedClassList {
1919      my @list = split /\s+/, $FIG_Config::feature_types;      my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;
1920      my %retVal = map { $_ => $_ } @list;      return @retVal;
     return %retVal;  
1921  }  }
1922    
1923  =head3 AdvancedClassList  =head3 SelectionTree
1924    
1925  C<< my @classes = SearchHelper::AdvancedClassList(); >>  C<< my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options); >>
1926    
1927  Return a list of advanced class names. This list is used to generate the directory  Display a selection tree.
1928  of available searches on the search page.  
1929    This method creates the HTML for a tree selection control. The tree is implemented as a set of
1930    nested HTML unordered lists. Each selectable element of the tree will contain a radio button. In
1931    addition, some of the tree nodes can contain hyperlinks.
1932    
1933    The tree itself is passed in as a multi-level list containing node names followed by
1934    contents. Each content element is a reference to a similar list. The first element of
1935    each list may be a hash reference. If so, it should contain one or both of the following
1936    keys.
1937    
1938    =over 4
1939    
1940    =item link
1941    
1942    The navigation URL to be popped up if the user clicks on the node name.
1943    
1944    =item value
1945    
1946    The form value to be returned if the user selects the tree node.
1947    
1948    =back
1949    
1950    The presence of a C<link> key indicates the node name will be hyperlinked. The presence of
1951    a C<value> key indicates the node name will have a radio button. If a node has no children,
1952    you may pass it a hash reference instead of a list reference.
1953    
1954    The following example shows the hash for a three-level tree with links on the second level and
1955    radio buttons on the third.
1956    
1957        [   Objects => [
1958                Entities => [
1959                    {link => "../docs/WhatIsAnEntity.html"},
1960                    Genome => {value => 'GenomeData'},
1961                    Feature => {value => 'FeatureData'},
1962                    Contig => {value => 'ContigData'},
1963                ],
1964                Relationships => [
1965                    {link => "../docs/WhatIsARelationShip.html"},
1966                    HasFeature => {value => 'GenomeToFeature'},
1967                    IsOnContig => {value => 'FeatureToContig'},
1968                ]
1969            ]
1970        ]
1971    
1972    Note how each leaf of the tree has a hash reference for its value, while the branch nodes
1973    all have list references.
1974    
1975    This next example shows how to set up a taxonomy selection field. The value returned
1976    by the tree control will be the taxonomy string for the selected node ready for use
1977    in a LIKE-style SQL filter. Only the single branch ending in campylobacter is shown for
1978    reasons of space.
1979    
1980        [   All => [
1981                {value => "%"},
1982                Bacteria => [
1983                    {value => "Bacteria%"},
1984                    Proteobacteria => [
1985                        {value => "Bacteria; Proteobacteria%"},
1986                        Epsilonproteobacteria => [
1987                            {value => "Bacteria; Proteobacteria;Epsilonproteobacteria%"},
1988                            Campylobacterales => [
1989                                {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales%"},
1990                                Campylobacteraceae =>
1991                                    {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales; Campylobacteraceae%"},
1992                                ...
1993                            ]
1994                            ...
1995                        ]
1996                        ...
1997                    ]
1998                    ...
1999                ]
2000                ...
2001            ]
2002        ]
2003    
2004  The reason we have to convert the list from a string is that the B<NMPDRSetup.pl>  
2005  script is only able to insert strings into the generated B<FIG_Config> file.  This method of tree storage allows the caller to control the order in which the tree nodes
2006    are displayed and to completely control value selection and use of hyperlinks. It is, however
2007    a bit complicated. Eventually, tree-building classes will be provided to simplify things.
2008    
2009    The parameters to this method are as follows.
2010    
2011    =over 4
2012    
2013    =item cgi
2014    
2015    CGI object used to generate the HTML.
2016    
2017    =item tree
2018    
2019    Reference to a hash describing a tree. See the description above.
2020    
2021    =item options
2022    
2023    Hash containing options for the tree display.
2024    
2025    =back
2026    
2027    The allowable options are as follows
2028    
2029    =over 4
2030    
2031    =item nodeImageClosed
2032    
2033    URL of the image to display next to the tree nodes when they are collapsed. Clicking
2034    on the image will expand a section of the tree. The default is C<../FIG/Html/plus.gif>.
2035    
2036    =item nodeImageOpen
2037    
2038    URL of the image to display next to the tree nodes when they are expanded. Clicking
2039    on the image will collapse a section of the tree. The default is C<../FIG/Html/minus.gif>.
2040    
2041    =item style
2042    
2043    Style to use for the tree. The default is C<tree>. Because the tree style is implemented
2044    as nested lists, the key components of this style are the definitions for the C<ul> and
2045    C<li> tags. The default style file contains the following definitions.
2046    
2047        .tree ul {
2048           margin-left: 0; padding-left: 22px
2049        }
2050        .tree li {
2051            list-style-type: none;
2052        }
2053    
2054    The default image is 22 pixels wide, so in the above scheme each tree level is indented from its
2055    parent by the width of the node image. This use of styles limits the things we can do in formatting
2056    the tree, but it has the advantage of vastly simplifying the tree creation.
2057    
2058    =item name
2059    
2060    Field name to give to the radio buttons in the tree. The default is C<selection>.
2061    
2062    =item target
2063    
2064    Frame target for links. The default is C<_self>.
2065    
2066    =item selected
2067    
2068    If specified, the value of the radio button to be pre-selected.
2069    
2070    =back
2071    
2072  =cut  =cut
2073    
2074  sub AdvancedClassList {  sub SelectionTree {
2075      return split /\s+/, $FIG_Config::advanced_classes;      # Get the parameters.
2076        my ($cgi, $tree, %options) = @_;
2077        # Get the options.
2078        my $optionThing = Tracer::GetOptions({ name => 'selection',
2079                                               nodeImageClosed => '../FIG/Html/plus.gif',
2080                                               nodeImageOpen => '../FIG/Html/minus.gif',
2081                                               style => 'tree',
2082                                               target => '_self',
2083                                               selected => undef},
2084                                             \%options);
2085        # Declare the return variable. We'll do the standard thing with creating a list
2086        # of HTML lines and rolling them together at the end.
2087        my @retVal = ();
2088        # Only proceed if the tree is present.
2089        if (defined($tree)) {
2090            # Validate the tree.
2091            if (ref $tree ne 'ARRAY') {
2092                Confess("Selection tree is not a list reference.");
2093            } elsif (scalar @{$tree} == 0) {
2094                # The tree is empty, so we do nothing.
2095            } elsif ($tree->[0] eq 'HASH') {
2096                Confess("Hash reference found at start of selection tree. The tree as a whole cannot have attributes, only tree nodes.");
2097            } else {
2098                # Here we have a real tree. Apply the tree style.
2099                push @retVal, $cgi->start_div({ class => $optionThing->{style} });
2100                # Give us a DIV ID.
2101                my $divID = GetDivID($optionThing->{name});
2102                # Show the tree.
2103                push @retVal, ShowBranch($cgi, "(root)", $divID, $tree, $optionThing, 'block');
2104                # Close the DIV block.
2105                push @retVal, $cgi->end_div();
2106            }
2107        }
2108        # Return the result.
2109        return join("\n", @retVal, "");
2110    }
2111    
2112    =head3 ShowBranch
2113    
2114    C<< my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType); >>
2115    
2116    This is a recursive method that displays a branch of the tree.
2117    
2118    =over 4
2119    
2120    =item cgi
2121    
2122    CGI object used to format HTML.
2123    
2124    =item label
2125    
2126    Label of this tree branch. It is only used in error messages.
2127    
2128    =item id
2129    
2130    ID to be given to this tree branch. The ID is used in the code that expands and collapses
2131    tree nodes.
2132    
2133    =item branch
2134    
2135    Reference to a list containing the content of the tree branch. The list contains an optional
2136    hash reference that is ignored and the list of children, each child represented by a name
2137    and then its contents. The contents could by a hash reference (indicating the attributes
2138    of a leaf node), or another tree branch.
2139    
2140    =item options
2141    
2142    Options from the original call to L</SelectionTree>.
2143    
2144    =item displayType
2145    
2146    C<block> if the contents of this list are to be displayed, C<none> if they are to be
2147    hidden.
2148    
2149    =item RETURN
2150    
2151    Returns one or more HTML lines that can be used to display the tree branch.
2152    
2153    =back
2154    
2155    =cut
2156    
2157    sub ShowBranch {
2158        # Get the parameters.
2159        my ($cgi, $label, $id, $branch, $options, $displayType) = @_;
2160        # Declare the return variable.
2161        my @retVal = ();
2162        # Start the branch.
2163        push @retVal, $cgi->start_ul({ id => $id, style => "display:$displayType" });
2164        # Check for the hash and choose the start location accordingly.
2165        my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0);
2166        # Get the list length.
2167        my $i1 = scalar(@{$branch});
2168        # Verify we have an even number of elements.
2169        if (($i1 - $i0) % 2 != 0) {
2170            Trace("Branch elements are from $i0 to $i1.") if T(3);
2171            Confess("Odd number of elements in tree branch $label.");
2172        } else {
2173            # Loop through the elements.
2174            for (my $i = $i0; $i < $i1; $i += 2) {
2175                # Get this node's label and contents.
2176                my ($myLabel, $myContent) = ($branch->[$i], $branch->[$i+1]);
2177                # Get an ID for this node's children (if any).
2178                my $myID = GetDivID($options->{name});
2179                # Now we need to find the list of children and the options hash.
2180                # This is a bit ugly because we allow the shortcut of a hash without an
2181                # enclosing list. First, we need some variables.
2182                my $attrHash = {};
2183                my @childHtml = ();
2184                my $hasChildren = 0;
2185                if (! ref $myContent) {
2186                    Confess("Invalid tree definition. Scalar found as content of node \"$myLabel\".");
2187                } elsif (ref $myContent eq 'HASH') {
2188                    # Here the node is a leaf and its content contains the link/value hash.
2189                    $attrHash = $myContent;
2190                } elsif (ref $myContent eq 'ARRAY') {
2191                    # Here the node may be a branch. Its content is a list.
2192                    my $len = scalar @{$myContent};
2193                    if ($len >= 1) {
2194                        # Here the first element of the list could by the link/value hash.
2195                        if (ref $myContent->[0] eq 'HASH') {
2196                            $attrHash = $myContent->[0];
2197                            # If there's data in the list besides the hash, it's our child list.
2198                            # We can pass the entire thing as the child list, because the hash
2199                            # is ignored.
2200                            if ($len > 1) {
2201                                $hasChildren = 1;
2202                            }
2203                        } else {
2204                            $hasChildren = 1;
2205                        }
2206                        # If we have children, create the child list with a recursive call.
2207                        if ($hasChildren) {
2208                            Trace("Processing children of $myLabel.") if T(4);
2209                            push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2210                            Trace("Children of $myLabel finished.") if T(4);
2211                        }
2212                    }
2213                }
2214                # Okay, it's time to pause and take stock. We have the label of the current node
2215                # in $myLabel, its attributes in $attrHash, and if it is NOT a leaf node, we
2216                # have a child list in @childHtml. If it IS a leaf node, $hasChildren is 0.
2217                # Compute the image HTML. It's tricky, because we have to deal with the open and
2218                # closed images.
2219                my @images = ($options->{nodeImageOpen}, $options->{nodeImageClosed});
2220                my $image = $images[$hasChildren];
2221                my $prefixHtml = $cgi->img({src => $image, id => "${myID}img"});
2222                if ($hasChildren) {
2223                    # If there are children, we wrap the image in a toggle hyperlink.
2224                    $prefixHtml = $cgi->a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" },
2225                                          $prefixHtml);
2226                }
2227                # Now the radio button, if any. Note we use "defined" in case the user wants the
2228                # value to be 0.
2229                if (defined $attrHash->{value}) {
2230                    # Due to a glitchiness in the CGI stuff, we have to build the attribute
2231                    # hash for the "input" method. If the item is pre-selected, we add
2232                    # "checked => undef" to the hash. Otherwise, we can't have "checked"
2233                    # at all.
2234                    my $radioParms = { type => 'radio',
2235                                       name => $options->{name},
2236                                       value => $attrHash->{value},
2237                                     };
2238                    if (defined $options->{selected} && $options->{selected} eq $attrHash->{value}) {
2239                        $radioParms->{checked} = undef;
2240                    }
2241                    $prefixHtml .= $cgi->input($radioParms);
2242                }
2243                # Next, we format the label.
2244                my $labelHtml = $myLabel;
2245                Trace("Formatting tree node for \"$myLabel\".") if T(4);
2246                # Apply a hyperlink if necessary.
2247                if (defined $attrHash->{link}) {
2248                    $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
2249                                         $labelHtml);
2250                }
2251                # Finally, roll up the child HTML. If there are no children, we'll get a null string
2252                # here.
2253                my $childHtml = join("\n", @childHtml);
2254                # Now we have all the pieces, so we can put them together.
2255                push @retVal, $cgi->li("$prefixHtml$labelHtml$childHtml");
2256            }
2257        }
2258        # Close the tree branch.
2259        push @retVal, $cgi->end_ul();
2260        # Return the result.
2261        return @retVal;
2262    }
2263    
2264    =head3 GetDivID
2265    
2266    C<< my $idString = SearchHelper::GetDivID($name); >>
2267    
2268    Return a new HTML ID string.
2269    
2270    =over 4
2271    
2272    =item name
2273    
2274    Name to be prefixed to the ID string.
2275    
2276    =item RETURN
2277    
2278    Returns a hopefully-unique ID string.
2279    
2280    =back
2281    
2282    =cut
2283    
2284    sub GetDivID {
2285        # Get the parameters.
2286        my ($name) = @_;
2287        # Compute the ID.
2288        my $retVal = "elt_$name$divCount";
2289        # Increment the counter to make sure this ID is not re-used.
2290        $divCount++;
2291        # Return the result.
2292        return $retVal;
2293  }  }
2294    
2295  =head2 Feature Column Methods  =head2 Feature Column Methods
2296    
2297  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
2298  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
2299  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
2300  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 1717  Line 2312 
2312    
2313  =head3 DefaultFeatureColumns  =head3 DefaultFeatureColumns
2314    
2315  C<< my $colNames = $shelp->DefaultFeatureColumns(); >>  C<< my @colNames = $shelp->DefaultFeatureColumns(); >>
2316    
2317  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
2318  identifiers can be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in  be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in order to
2319  order to produce the column titles and row values.  produce the column titles and row values.
2320    
2321  =cut  =cut
2322    
# Line 1729  Line 2324 
2324      # Get the parameters.      # Get the parameters.
2325      my ($self) = @_;      my ($self) = @_;
2326      # Return the result.      # Return the result.
2327      return ['orgName', 'function', 'gblink', 'protlink',      return qw(orgName function gblink protlink);
             FeatureQuery::AdditionalColumns($self)];  
2328  }  }
2329    
2330  =head3 FeatureColumnTitle  =head3 FeatureColumnTitle
# Line 1762  Line 2356 
2356      if ($colName =~ /^X=(.+)$/) {      if ($colName =~ /^X=(.+)$/) {
2357          # Here we have an extra column.          # Here we have an extra column.
2358          $retVal = $1;          $retVal = $1;
     } elsif ($colName eq 'orgName') {  
         $retVal = "Name";  
     } elsif ($colName eq 'fid') {  
         $retVal = "FIG ID";  
2359      } elsif ($colName eq 'alias') {      } elsif ($colName eq 'alias') {
2360          $retVal = "External Aliases";          $retVal = "External Aliases";
2361        } elsif ($colName eq 'fid') {
2362            $retVal = "FIG ID";
2363      } elsif ($colName eq 'function') {      } elsif ($colName eq 'function') {
2364          $retVal = "Functional Assignment";          $retVal = "Functional Assignment";
2365      } elsif ($colName eq 'gblink') {      } elsif ($colName eq 'gblink') {
2366          $retVal = "GBrowse";          $retVal = "GBrowse";
     } elsif ($colName eq 'protlink') {  
         $retVal = "NMPDR Protein Page";  
2367      } elsif ($colName eq 'group') {      } elsif ($colName eq 'group') {
2368          $retVal = "NMDPR Group";          $retVal = "NMDPR Group";
2369        } elsif ($colName =~ /^keyword:(.+)$/) {
2370            $retVal = ucfirst $1;
2371        } elsif ($colName eq 'orgName') {
2372            $retVal = "Organism and Gene ID";
2373        } elsif ($colName eq 'protlink') {
2374            $retVal = "NMPDR Protein Page";
2375        } elsif ($colName eq 'subsystem') {
2376            $retVal = "Subsystems";
2377      }      }
2378      # Return the result.      # Return the result.
2379      return $retVal;      return $retVal;
2380  }  }
2381    
2382    
2383  =head3 FeatureColumnValue  =head3 FeatureColumnValue
2384    
2385  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>
# Line 1831  Line 2430 
2430          if (defined $extraCols->{$1}) {          if (defined $extraCols->{$1}) {
2431              $retVal = $extraCols->{$1};              $retVal = $extraCols->{$1};
2432          }          }
     } 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);  
2433      } elsif ($colName eq 'alias') {      } elsif ($colName eq 'alias') {
2434          # 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.
2435          # 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.
2436          $retVal = "%%aliases=$fid";          $retVal = "%%alias=$fid";
2437        } elsif ($colName eq 'fid') {
2438            # Here we have the raw feature ID. We hyperlink it to the protein page.
2439            $retVal = HTML::set_prot_links($fid);
2440      } elsif ($colName eq 'function') {      } elsif ($colName eq 'function') {
2441          # The functional assignment is just a matter of getting some text.          # The functional assignment is just a matter of getting some text.
2442          ($retVal) = $record->Value('Feature(assignment)');          ($retVal) = $record->Value('Feature(assignment)');
2443      } elsif ($colName eq 'gblink') {      } elsif ($colName eq 'gblink') {
2444          # 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.
2445          my $gurl = "GetGBrowse.cgi?fid=$fid";          $retVal = FakeButton('GBrowse', "GetGBrowse.cgi", undef,
2446          $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 })  
                          );  
2447      } elsif ($colName eq 'group') {      } elsif ($colName eq 'group') {
2448          # Get the NMPDR group name.          # Get the NMPDR group name.
2449          my (undef, $group) = $self->OrganismData($fid);          my (undef, $group) = $self->OrganismData($fid);
# Line 1865  Line 2451 
2451          my $nurl = $sprout->GroupPageName($group);          my $nurl = $sprout->GroupPageName($group);
2452          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },
2453                            $group);                            $group);
2454        } elsif ($colName =~ /^keyword:(.+)$/) {
2455            # Here we want keyword-related values. This is also expensive, so
2456            # we compute them when the row is displayed.
2457            $retVal = "%%$colName=$fid";
2458        } elsif ($colName eq 'orgName') {
2459            # Here we want the formatted organism name and feature number.
2460            $retVal = $self->FeatureName($fid);
2461        } elsif ($colName eq 'protlink') {
2462            # Here we want a link to the protein page using the official NMPDR button.
2463            $retVal = FakeButton('NMPDR', "protein.cgi", undef,
2464                              prot => $fid, SPROUT => 1, new_framework => 0,
2465                              user => '');
2466        }elsif ($colName eq 'subsystem') {
2467            # Another run-time column: subsystem list.
2468            $retVal = "%%subsystem=$fid";
2469      }      }
2470      # Return the result.      # Return the result.
2471      return $retVal;      return $retVal;
# Line 1903  Line 2504 
2504      # Get the Sprout and CGI objects.      # Get the Sprout and CGI objects.
2505      my $sprout = $self->DB();      my $sprout = $self->DB();
2506      my $cgi = $self->Q();      my $cgi = $self->Q();
2507        Trace("Runtime column $type with text \"$text\" found.") if T(4);
2508      # Separate the text into a type and data.      # Separate the text into a type and data.
2509      if ($type eq 'aliases') {      if ($type eq 'alias') {
2510          # Here the caller wants external alias links for a feature. The text          # Here the caller wants external alias links for a feature. The text
2511          # is the feature ID.          # is the feature ID.
2512          my $fid = $text;          my $fid = $text;
# Line 1919  Line 2521 
2521              # Ask the HTML processor to hyperlink them.              # Ask the HTML processor to hyperlink them.
2522              $retVal = HTML::set_prot_links($cgi, $aliasList);              $retVal = HTML::set_prot_links($cgi, $aliasList);
2523          }          }
2524        } elsif ($type eq 'subsystem') {
2525            # Here the caller wants the subsystems in which this feature participates.
2526            # The text is the feature ID. We will list the subsystem names with links
2527            # to the subsystem's summary page.
2528            my $fid = $text;
2529            # Get the subsystems.
2530            Trace("Generating subsystems for feature $fid.") if T(4);
2531            my %subs = $sprout->SubsystemsOf($fid);
2532            # Extract the subsystem names.
2533            my @names = map { HTML::sub_link($cgi, $_) } sort keys %subs;
2534            # String them into a list.
2535            $retVal = join(", ", @names);
2536        } elsif ($type =~ /^keyword:(.+)$/) {
2537            # Here the caller wants the value of the named keyword. The text is the
2538            # feature ID.
2539            my $keywordName = $1;
2540            my $fid = $text;
2541            # Get the attribute values.
2542            Trace("Getting $keywordName values for feature $fid.") if T(4);
2543            my @values = $sprout->GetFlat(['Feature'], "Feature(id) = ?", [$fid],
2544                                          "Feature($keywordName)");
2545            # String them into a list.
2546            $retVal = join(", ", @values);
2547      }      }
2548      # Return the result.      # Return the result.
2549      return $retVal;      return $retVal;
2550  }  }
2551    
2552    =head3 SaveOrganismData
2553    
2554    C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain); >>
2555    
2556    Format the name of an organism and the display version of its group name. The incoming
2557    data should be the relevant fields from the B<Genome> record in the database. The
2558    data will also be stored in the genome cache for later use in posting search results.
2559    
2560    =over 4
2561    
2562    =item group
2563    
2564    Name of the genome's group as it appears in the database.
2565    
2566    =item genomeID
2567    
2568    ID of the relevant genome.
2569    
2570    =item genus
2571    
2572    Genus of the genome's organism. If undefined or null, it will be assumed the genome is not
2573    in the database. In this case, the organism name is derived from the genomeID and the group
2574    is automatically the supporting-genomes group.
2575    
2576    =item species
2577    
2578    Species of the genome's organism.
2579    
2580    =item strain
2581    
2582    Strain of the species represented by the genome.
2583    
2584    =item RETURN
2585    
2586    Returns a two-element list. The first element is the formatted genome name. The second
2587    element is the display name of the genome's group.
2588    
2589    =back
2590    
2591    =cut
2592    
2593    sub SaveOrganismData {
2594        # Get the parameters.
2595        my ($self, $group, $genomeID, $genus, $species, $strain) = @_;
2596        # Declare the return values.
2597        my ($name, $displayGroup);
2598        # If the organism does not exist, format an unknown name and a blank group.
2599        if (! defined($genus)) {
2600            $name = "Unknown Genome $genomeID";
2601            $displayGroup = "";
2602        } else {
2603            # It does exist, so format the organism name.
2604            $name = "$genus $species";
2605            if ($strain) {
2606                $name .= " $strain";
2607            }
2608            # Compute the display group. This is currently the same as the incoming group
2609            # name unless it's the supporting group, which is nulled out.
2610            $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2611        }
2612        # Cache the group and organism data.
2613        my $cache = $self->{orgs};
2614        $cache->{$genomeID} = [$name, $displayGroup];
2615        # Return the result.
2616        return ($name, $displayGroup);
2617    }
2618    
2619    =head3 ValidateKeywords
2620    
2621    C<< my $okFlag = $shelp->ValidateKeywords($keywordString, $required); >>
2622    
2623    Insure that a keyword string is reasonably valid. If it is invalid, a message will be
2624    set.
2625    
2626    =over 4
2627    
2628    =item keywordString
2629    
2630    Keyword string specified as a parameter to the current search.
2631    
2632    =item required
2633    
2634    TRUE if there must be at least one keyword specified, else FALSE.
2635    
2636    =item RETURN
2637    
2638    Returns TRUE if the keyword string is valid, else FALSE. Note that a null keyword string
2639    is acceptable if the I<$required> parameter is not specified.
2640    
2641    =back
2642    
2643    =cut
2644    
2645    sub ValidateKeywords {
2646        # Get the parameters.
2647        my ($self, $keywordString, $required) = @_;
2648        # Declare the return variable.
2649        my $retVal = 0;
2650        my @wordList = split /\s+/, $keywordString;
2651        # Right now our only real worry is a list of all minus words. The problem with it is that
2652        # it will return an incorrect result.
2653        my @plusWords = grep { $_ =~ /^[^\-]/ } @wordList;
2654        if (! @wordList) {
2655            if ($required) {
2656                $self->SetMessage("No search words specified.");
2657            } else {
2658                $retVal = 1;
2659            }
2660        } elsif (! @plusWords) {
2661            $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
2662        } else {
2663            $retVal = 1;
2664        }
2665        # Return the result.
2666        return $retVal;
2667    }
2668    
2669    =head3 FakeButton
2670    
2671    C<< my $html = SearchHelper::FakeButton($caption, $url, $target, %parms); >>
2672    
2673    Create a fake button that hyperlinks to the specified URL with the specified parameters.
2674    Unlike a real button, this one won't visibly click, but it will take the user to the
2675    correct place.
2676    
2677    The parameters of this method are deliberately identical to L</Formlet> so that we
2678    can switch easily from real buttons to fake ones in the code.
2679    
2680    =over 4
2681    
2682    =item caption
2683    
2684    Caption to be put on the button.
2685    
2686    =item url
2687    
2688    URL for the target page or script.
2689    
2690    =item target
2691    
2692    Frame or target in which the new page should appear. If C<undef> is specified,
2693    the default target will be used.
2694    
2695    =item parms
2696    
2697    Hash containing the parameter names as keys and the parameter values as values.
2698    These will be appended to the URL.
2699    
2700    =back
2701    
2702    =cut
2703    
2704    sub FakeButton {
2705        # Get the parameters.
2706        my ($caption, $url, $target, %parms) = @_;
2707        # Declare the return variable.
2708        my $retVal;
2709        # Compute the target URL.
2710        my $targetUrl = "$url?" . join(";", map { "$_=" . uri_escape($parms{$_}) } keys %parms);
2711        # Compute the target-frame HTML.
2712        my $targetHtml = ($target ? " target=\"$target\"" : "");
2713        # Assemble the result.
2714        return "<a href=\"$targetUrl\" $targetHtml><div class=\"button2 button\">$caption</div></a>";
2715    }
2716    
2717    =head3 Formlet
2718    
2719    C<< my $html = SearchHelper::Formlet($caption, $url, $target, %parms); >>
2720    
2721    Create a mini-form that posts to the specified URL with the specified parameters. The
2722    parameters will be stored in hidden fields, and the form's only visible control will
2723    be a submit button with the specified caption.
2724    
2725    Note that we don't use B<CGI.pm> services here because they generate forms with extra characters
2726    and tags that we don't want to deal with.
2727    
2728    =over 4
2729    
2730    =item caption
2731    
2732    Caption to be put on the form button.
2733    
2734    =item url
2735    
2736    URL to be put in the form's action parameter.
2737    
2738    =item target
2739    
2740    Frame or target in which the form results should appear. If C<undef> is specified,
2741    the default target will be used.
2742    
2743    =item parms
2744    
2745    Hash containing the parameter names as keys and the parameter values as values.
2746    
2747    =back
2748    
2749    =cut
2750    
2751    sub Formlet {
2752        # Get the parameters.
2753        my ($caption, $url, $target, %parms) = @_;
2754        # Compute the target HTML.
2755        my $targetHtml = ($target ? " target=\"$target\"" : "");
2756        # Start the form.
2757        my $retVal = "<form method=\"POST\" action=\"$url\"$target>";
2758        # Add the parameters.
2759        for my $parm (keys %parms) {
2760            $retVal .= "<input type=\"hidden\" name=\"$parm\" value=\"$parms{$parm}\" />";
2761        }
2762        # Put in the button.
2763        $retVal .= "<input type=\"submit\" name=\"submit\" value=\"$caption\" class=\"button\" />";
2764        # Close the form.
2765        $retVal .= "</form>";
2766        # Return the result.
2767        return $retVal;
2768    }
2769    
2770  =head2 Virtual Methods  =head2 Virtual Methods
2771    
2772  =head3 Form  =head3 Form
# Line 1951  Line 2794 
2794    
2795  =head3 SortKey  =head3 SortKey
2796    
2797  C<< my $key = $shelp->SortKey($record); >>  C<< my $key = $shelp->SortKey($fdata); >>
2798    
2799  Return the sort key for the specified record. The default is to sort by feature name,  Return the sort key for the specified feature data. The default is to sort by feature name,
2800  floating NMPDR organisms to the top. This sort may be overridden by the search class  floating NMPDR organisms to the top. If a full-text search is used, then the default
2801  to provide fancier functionality. This method is called by B<PutFeature>, so it  sort is by relevance followed by feature name. This sort may be overridden by the
2802  is only used for feature searches. A non-feature search would presumably have its  search class to provide fancier functionality. This method is called by
2803  own sort logic.  B<PutFeature>, so it is only used for feature searches. A non-feature search
2804    would presumably have its own sort logic.
2805    
2806  =over 4  =over 4
2807    
2808  =item record  =item record
2809    
2810  The C<DBObject> from which the current row of data is derived.  The C<FeatureData> containing the current feature.
2811    
2812  =item RETURN  =item RETURN
2813    
# Line 1975  Line 2819 
2819    
2820  sub SortKey {  sub SortKey {
2821      # Get the parameters.      # Get the parameters.
2822      my ($self, $record) = @_;      my ($self, $fdata) = @_;
2823      # Get the feature ID from the record.      # Get the feature ID from the record.
2824      my ($fid) = $record->Value('Feature(id)');      my $fid = $fdata->FID();
2825      # Get the group from the feature ID.      # Get the group from the feature ID.
2826      my $group = $self->FeatureGroup($fid);      my $group = $self->FeatureGroup($fid);
2827      # Ask the feature query object to form the sort key.      # Ask the feature query object to form the sort key.
2828      my $retVal = FeatureQuery::SortKey($self, $group, $record);      my $retVal = $fdata->SortKey($self, $group);
2829      # Return the result.      # Return the result.
2830      return $retVal;      return $retVal;
2831  }  }
2832    
   
2833  1;  1;

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.27

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3