[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.15, Fri Nov 10 22:01:36 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 244  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 255  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 265  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 288  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 298  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 358  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 452  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 658  Line 699 
699      # Check for a first-call situation.      # Check for a first-call situation.
700      if (! defined $self->{cols}) {      if (! defined $self->{cols}) {
701          Trace("Setting up the columns.") if T(3);          Trace("Setting up the columns.") if T(3);
702          # Here we need to set up the column information. Start with the extras,          # Here we need to set up the column information. First we accumulate the extras,
703          # sorted by column name.          # sorted by column name.
704          my @colNames = ();          my @xtraNames = ();
705          for my $col (sort keys %{$extraCols}) {          for my $col (sort keys %{$extraCols}) {
706              push @colNames, "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.          # Add the default columns.
715          push @colNames, $self->DefaultFeatureColumns();          push @colNames, $self->DefaultFeatureColumns();
716          # Add any additional columns requested by the feature filter.          # Add any additional columns requested by the feature filter.
717          push @colNames, FeatureQuery::AdditionalColumns($self);          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.          # Save the full list.
724          $self->{cols} = \@colNames;          $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 = $fd->FID();      my $fid = $fd->FID();
# Line 945  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 982  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.      # This variable will be cleared if an error is detected.
1036      my $okFlag = 1;      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 incoming type is $incomingType, desired type is $desiredType.") if T(4);      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
# Line 1002  Line 1049 
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;              $okFlag = 0;
1054          } else {          } else {
1055              # Set the FASTA label.              # Set the FASTA label.
# Line 1019  Line 1066 
1066                  Trace(length $fastaData . " characters returned for DNA of $fastaLabel.") if T(3);                  Trace(length $fastaData . " characters returned for DNA of $fastaLabel.") if T(3);
1067              }              }
1068          }          }
     } elsif ($incomingType eq 'prot' && $desiredType eq 'dna') {  
         # Here we're being asked to do an impossible conversion.  
         $self->SetMessage("Cannot convert a protein sequence to DNA.");  
         $okFlag = 0;  
1069      } else {      } else {
1070          Trace("Analyzing FASTA sequence.") if T(4);          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.
# Line 1035  Line 1078 
1078              Trace("No label found in match to sequence:\n$sequence") if T(4);              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?");
             $fastaData = Sprout::Protein($fastaData);  
             # Check for bad characters.  
             if ($fastaData =~ /X/) {  
                 $self->SetMessage("Invalid characters detected. Is the input really of type $incomingType?");  
                 $okFlag = 0;  
             }  
         } elsif ($desiredType eq 'dna' && $fastaData =~ /[^agct]/i) {  
             $self->SetMessage("Invaid characters detected. Is the input really a DNA sequence?");  
1090              $okFlag = 0;              $okFlag = 0;
1091          }          }
1092      }      }
# Line 1070  Line 1105 
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 1223  Line 1408 
1408          # the search box. This allows the user to type text and have all genomes containing          # 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\" " .          push @lines, "<br />" .
1412                       "size=\"30\" onBlur=\"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.          # Next are the buttons to set and clear selections.
1415          push @lines, "<br />";          push @lines, "<br />";
1416          push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";          push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";
# Line 1349  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 1369  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  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>  values can be used to select features by genome using the B<FeatureQuery>
1587  object.  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    =back
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 1469  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 1562  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 1572  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 1603  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 (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF ShowURL)) {          if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) {
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 1617  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 1681  Line 1920 
1920      return @retVal;      return @retVal;
1921  }  }
1922    
1923    =head3 SelectionTree
1924    
1925    C<< my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options); >>
1926    
1927    Display a selection tree.
1928    
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    
2005    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
2073    
2074    sub SelectionTree {
2075        # 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 1758  Line 2369 
2369      } elsif ($colName =~ /^keyword:(.+)$/) {      } elsif ($colName =~ /^keyword:(.+)$/) {
2370          $retVal = ucfirst $1;          $retVal = ucfirst $1;
2371      } elsif ($colName eq 'orgName') {      } elsif ($colName eq 'orgName') {
2372          $retVal = "Feature Name";          $retVal = "Organism and Gene ID";
2373      } elsif ($colName eq 'protlink') {      } elsif ($colName eq 'protlink') {
2374          $retVal = "NMPDR Protein Page";          $retVal = "NMPDR Protein Page";
2375      } elsif ($colName eq 'subsystem') {      } elsif ($colName eq 'subsystem') {
# Line 1831  Line 2442 
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 })  
                          );  
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 1852  Line 2460 
2460          $retVal = $self->FeatureName($fid);          $retVal = $self->FeatureName($fid);
2461      } elsif ($colName eq 'protlink') {      } elsif ($colName eq 'protlink') {
2462          # 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.
2463          my $hurl = HTML::fid_link($cgi, $fid, 0, 1);          $retVal = FakeButton('NMPDR', "protein.cgi", undef,
2464          $retVal = $cgi->a({ href => $hurl, title => "Protein page for $fid" },                            prot => $fid, SPROUT => 1, new_framework => 0,
2465                            $cgi->img({ src => "../images/button-nmpdr.png",                            user => '');
                                      border => 0 })  
                          );  
2466      }elsif ($colName eq 'subsystem') {      }elsif ($colName eq 'subsystem') {
2467          # Another run-time column: subsystem list.          # Another run-time column: subsystem list.
2468          $retVal = "%%subsystem=$fid";          $retVal = "%%subsystem=$fid";
# Line 1923  Line 2529 
2529          # Get the subsystems.          # Get the subsystems.
2530          Trace("Generating subsystems for feature $fid.") if T(4);          Trace("Generating subsystems for feature $fid.") if T(4);
2531          my %subs = $sprout->SubsystemsOf($fid);          my %subs = $sprout->SubsystemsOf($fid);
2532          # Convert them to links.          # Extract the subsystem names.
2533          my @links = map { HTML::sub_link($cgi, $_) } sort keys %subs;          my @names = map { HTML::sub_link($cgi, $_) } sort keys %subs;
2534          # String them into a list.          # String them into a list.
2535          $retVal = join(", ", @links);          $retVal = join(", ", @names);
2536      } elsif ($type =~ /^keyword:(.+)$/) {      } elsif ($type =~ /^keyword:(.+)$/) {
2537          # Here the caller wants the value of the named keyword. The text is the          # Here the caller wants the value of the named keyword. The text is the
2538          # feature ID.          # feature ID.
# Line 2010  Line 2616 
2616      return ($name, $displayGroup);      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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3