[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.22, Sat Dec 2 09:45:30 2006 UTC revision 1.29, Sat Apr 14 21:41:25 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 230  Line 235 
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.
237    
238    In addition to the finding and filtering, it is necessary to send status messages
239    to the output so that the user does not get bored waiting for results. The L</PrintLine>
240    method performs this function. The single parameter should be text to be
241    output to the browser. In general, you'll invoke it as follows.
242    
243        $self->PrintLine("...my message text...<br />");
244    
245    The break tag is optional. When the Find method gets control, a paragraph will
246    have been started so that everything is XHTML-compliant.
247    
248  If you wish to add your own extra columns to the output, use the B<AddExtraColumns>  If you wish to add your own extra columns to the output, use the B<AddExtraColumns>
249  method of the feature query object.  method of the feature query object.
250    
# Line 251  Line 266 
266    
267  =head3 new  =head3 new
268    
269  C<< my $shelp = SearchHelper->new($query); >>  C<< my $shelp = SearchHelper->new($cgi); >>
270    
271  Construct a new SearchHelper object.  Construct a new SearchHelper object.
272    
# Line 272  Line 287 
287      my $session_id = $cgi->param("SessionID");      my $session_id = $cgi->param("SessionID");
288      my $type = "old";      my $type = "old";
289      if (! $session_id) {      if (! $session_id) {
290            Trace("No session ID found.") if T(3);
291          # Here we're starting a new session. We create the session ID and          # Here we're starting a new session. We create the session ID and
292          # store it in the query object.          # store it in the query object.
293          $session_id = NewSessionID();          $session_id = NewSessionID();
294          $type = "new";          $type = "new";
295          $cgi->param(-name => 'SessionID', -value => $session_id);          $cgi->param(-name => 'SessionID', -value => $session_id);
296        } else {
297            Trace("Session ID is $session_id.") if T(3);
298      }      }
299      # Compute the subclass name.      # Compute the subclass name.
300      my $subClass;      my $subClass;
# Line 307  Line 325 
325                    genomeList => undef,                    genomeList => undef,
326                    genomeParms => [],                    genomeParms => [],
327                    filtered => 0,                    filtered => 0,
328                      extraPos => 0,
329                   };                   };
330      # Bless and return it.      # Bless and return it.
331      bless $retVal, $class;      bless $retVal, $class;
# Line 367  Line 386 
386      return ($self->{type} eq 'new');      return ($self->{type} eq 'new');
387  }  }
388    
389    =head3 SetExtraPos
390    
391    C<< $shelp->SetExtraPos($newValue); >>
392    
393    Indicate whether the extra columns should be in the front (C<0>) or end (C<1>) columns of the results.
394    
395    =over 4
396    
397    =item newValue
398    
399    C<1> if the extra columns should be displayed at the end, else C<0>.
400    
401    =back
402    
403    =cut
404    
405    sub SetExtraPos {
406        my ($self, $newValue) = @_;
407        $self->{extraPos} = $newValue;
408    }
409    
410  =head3 ID  =head3 ID
411    
412  C<< my $sessionID = $shelp->ID(); >>  C<< my $sessionID = $shelp->ID(); >>
# Line 669  Line 709 
709      # Check for a first-call situation.      # Check for a first-call situation.
710      if (! defined $self->{cols}) {      if (! defined $self->{cols}) {
711          Trace("Setting up the columns.") if T(3);          Trace("Setting up the columns.") if T(3);
712          # Here we need to set up the column information. Start with the extras,          # Tell the user what's happening.
713            $self->PrintLine("Creating output columns.<br />");
714            # Here we need to set up the column information. First we accumulate the extras,
715          # sorted by column name.          # sorted by column name.
716          my @colNames = ();          my @xtraNames = ();
717          for my $col (sort keys %{$extraCols}) {          for my $col (sort keys %{$extraCols}) {
718              push @colNames, "X=$col";              push @xtraNames, "X=$col";
719            }
720            # Set up the column name array.
721            my @colNames = ();
722            # If extras go at the beginning, put them in first.
723            if (! $self->{extraPos}) {
724                push @colNames, @xtraNames;
725          }          }
726          # Add the default columns.          # Add the default columns.
727          push @colNames, $self->DefaultFeatureColumns();          push @colNames, $self->DefaultFeatureColumns();
728          # Add any additional columns requested by the feature filter.          # Add any additional columns requested by the feature filter.
729          push @colNames, FeatureQuery::AdditionalColumns($self);          push @colNames, FeatureQuery::AdditionalColumns($self);
730            # If extras go at the end, put them in here.
731            if ($self->{extraPos}) {
732                push @colNames, @xtraNames;
733            }
734            Trace("Full column list determined.") if T(3);
735          # Save the full list.          # Save the full list.
736          $self->{cols} = \@colNames;          $self->{cols} = \@colNames;
737          # Write out the column headers. This also prepares the cache file to receive          # Write out the column names. This also prepares the cache file to receive
738          # output.          # output.
739          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});          Trace("Writing column headers.") if T(3);
740            $self->WriteColumnHeaders(@{$self->{cols}});
741            Trace("Column headers written.") if T(3);
742      }      }
743      # Get the feature ID.      # Get the feature ID.
744      my $fid = $fd->FID();      my $fid = $fd->FID();
745      # Loop through the column headers, producing the desired data.      # Loop through the column headers, producing the desired data. The first column
746      my @output = ();      # is the feature ID. The feature ID does not show up in the output: its purpose
747        # is to help the various output formatters.
748        my @output = ($fid);
749      for my $colName (@{$self->{cols}}) {      for my $colName (@{$self->{cols}}) {
750          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
751      }      }
# Line 777  Line 834 
834          # We found one, so close it.          # We found one, so close it.
835          Trace("Closing session file.") if T(2);          Trace("Closing session file.") if T(2);
836          close $self->{fileHandle};          close $self->{fileHandle};
837            # Tell the user.
838            my $cgi = $self->Q();
839            $self->PrintLine("Output formatting complete.<br />");
840      }      }
841  }  }
842    
# Line 994  Line 1054 
1054      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
1055      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
1056      Trace("FASTA desired type is $desiredType.") if T(4);      Trace("FASTA desired type is $desiredType.") if T(4);
1057      # Check for a feature specification.      # Check for a feature specification. The smoking gun for that is a vertical bar.
1058      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
1059          # Here we have a feature ID in $1. We'll need the Sprout object to process          # Here we have a feature ID in $1. We'll need the Sprout object to process
1060          # it.          # it.
# Line 1009  Line 1069 
1069              $self->SetMessage("No gene found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
1070              $okFlag = 0;              $okFlag = 0;
1071          } else {          } else {
1072              # Set the FASTA label.              # Set the FASTA label. The ID is the first favored alias.
1073              my $fastaLabel = $fid;              my $favored = $self->Q()->param('FavoredAlias') || 'fig';
1074                my $favorLen = length $favored;
1075                ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid);
1076                if (! $fastaLabel) {
1077                    # In an emergency, fall back to the original ID.
1078                    $fastaLabel = $fid;
1079                }
1080              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
1081              if ($desiredType eq 'prot') {              if ($desiredType eq 'prot') {
1082                  # We want protein, so get the translation.                  # We want protein, so get the translation.
# Line 1042  Line 1108 
1108          $fastaData =~ s/\n//g;          $fastaData =~ s/\n//g;
1109          $fastaData =~ s/\s+//g;          $fastaData =~ s/\s+//g;
1110          # Finally, verify that it's DNA if we're doing DNA stuff.          # Finally, verify that it's DNA if we're doing DNA stuff.
1111          if ($desiredType eq 'dna' && $fastaData =~ /[^agct]/i) {          if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn]/i) {
1112              $self->SetMessage("Invaid characters detected. Is the input really a DNA sequence?");              $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?");
1113              $okFlag = 0;              $okFlag = 0;
1114          }          }
1115      }      }
# Line 1114  Line 1180 
1180      # Read in the subsystems.      # Read in the subsystems.
1181      my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],      my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1182                                 ['Subsystem(classification)', 'Subsystem(id)']);                                 ['Subsystem(classification)', 'Subsystem(id)']);
1183        # Put any unclassified subsystems at the end. They will always be at the beginning, so if one
1184        # is at the end, ALL subsystems are unclassified and we don't bother.
1185        if ($#subs >= 0 && $subs[$#subs]->[0] ne '') {
1186            while ($subs[0]->[0] eq '') {
1187                my $classLess = shift @subs;
1188                push @subs, $classLess;
1189            }
1190        }
1191      # Declare the return variable.      # Declare the return variable.
1192      my @retVal = ();      my @retVal = ();
1193      # Each element in @subs represents a leaf node, so as we loop through it we will be      # Each element in @subs represents a leaf node, so as we loop through it we will be
# Line 1188  Line 1262 
1262              if ($optionThing->{links}) {              if ($optionThing->{links}) {
1263                  # Compute the link value.                  # Compute the link value.
1264                  my $linkable = uri_escape($id);                  my $linkable = uri_escape($id);
1265                  $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;SPROUT=1";                  $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;show_clusters=1;SPROUT=1";
1266              }              }
1267              if ($optionThing->{radio}) {              if ($optionThing->{radio}) {
1268                  # Compute the radio value.                  # Compute the radio value.
# Line 1452  Line 1526 
1526  =item rows  =item rows
1527    
1528  Reference to a list of table rows. Each table row must be in HTML form with all  Reference to a list of table rows. Each table row must be in HTML form with all
1529  the TR and TD tags set up. The first TD or TH tag in each row will be modified to  the TR and TD tags set up. The first TD or TH tag in the first non-colspanned row
1530  set the width. Everything else will be left as is.  will be modified to set the width. Everything else will be left as is.
1531    
1532  =item RETURN  =item RETURN
1533    
# Line 1468  Line 1542 
1542      my ($self, $rows) = @_;      my ($self, $rows) = @_;
1543      # Get the CGI object.      # Get the CGI object.
1544      my $cgi = $self->Q();      my $cgi = $self->Q();
1545      # Fix the widths on the first column. Note that we eschew the use of the "g"      # The first column of the first row must have its width fixed.
1546        # This flag will be set to FALSE when that happens.
1547        my $needWidth = 1;
1548      # modifier becase we only want to change the first tag. Also, if a width      # modifier becase we only want to change the first tag. Also, if a width
1549      # is already specified on the first column bad things will happen.      # is already specified on the first column bad things will happen.
1550      for my $row (@{$rows}) {      for my $row (@{$rows}) {
1551          $row =~ s/(<td|th)/$1 width="150"/i;          # See if this row needs a width.
1552            if ($needWidth && $row =~ /<(td|th) ([^>]+)>/i) {
1553                # Here we have a first cell and its tag parameters are in $2.
1554                my $elements = $2;
1555                if ($elements !~ /colspan/i) {
1556                    Trace("No colspan tag found in element \'$elements\'.") if T(3);
1557                    # Here there's no colspan, so we plug in the width. We
1558                    # eschew the "g" modifier on the substitution because we
1559                    # only want to update the first cell.
1560                    $row =~ s/(<(td|th))/$1 width="150"/i;
1561                    # Denote we don't need this any more.
1562                    $needWidth = 0;
1563                }
1564            }
1565      }      }
1566      # Create the table.      # Create the table.
1567      my $retVal = $cgi->table({border => 2, cellspacing => 2,      my $retVal = $cgi->table({border => 2, cellspacing => 2,
# Line 1519  Line 1608 
1608      my $retVal = $cgi->Tr($cgi->td("Results/Page"),      my $retVal = $cgi->Tr($cgi->td("Results/Page"),
1609                            $cgi->td($cgi->popup_menu(-name => 'PageSize',                            $cgi->td($cgi->popup_menu(-name => 'PageSize',
1610                                                      -values => [10, 25, 50, 100, 1000],                                                      -values => [10, 25, 50, 100, 1000],
1611                                                      -default => $pageSize) . " " .                                                      -default => $pageSize)),
                                    $cgi->checkbox(-name => 'ShowURL',  
                                                   -value => 1,  
                                                   -label => 'Show URL',  
                                                   -checked => 1)),  
1612                            $cgi->td($cgi->submit(-class => 'goButton',                            $cgi->td($cgi->submit(-class => 'goButton',
1613                                                  -name => 'Search',                                                  -name => 'Search',
1614                                                  -value => $realCaption)));                                                  -value => $realCaption)));
# Line 1533  Line 1618 
1618    
1619  =head3 FeatureFilterRows  =head3 FeatureFilterRows
1620    
1621  C<< my $htmlText = $shelp->FeatureFilterRows(); >>  C<< my $htmlText = $shelp->FeatureFilterRows(@subset); >>
1622    
1623  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
1624  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>
1625  object.  object.
1626    
1627    =over 4
1628    
1629    =item subset
1630    
1631    List of rows to display. The default (C<all>) is to display all rows.
1632    C<words> displays the word search box, C<subsys> displays the subsystem
1633    selector, and C<options> displays the options row.
1634    
1635    =item RETURN
1636    
1637    Returns the html text for table rows containing the desired feature filtering controls.
1638    
1639    =back
1640    
1641  =cut  =cut
1642    
1643  sub FeatureFilterRows {  sub FeatureFilterRows {
1644      # Get the parameters.      # Get the parameters.
1645      my ($self) = @_;      my ($self, @subset) = @_;
1646        if (@subset == 0 || $subset[0] eq 'all') {
1647            @subset = qw(words subsys options);
1648        }
1649      # Return the result.      # Return the result.
1650      return FeatureQuery::FilterRows($self);      return FeatureQuery::FilterRows($self, @subset);
1651  }  }
1652    
1653  =head3 GBrowseFeatureURL  =head3 GBrowseFeatureURL
# Line 1768  Line 1870 
1870          # a singleton list, but that's okay.          # a singleton list, but that's okay.
1871          my @values = split (/\0/, $parms{$parmKey});          my @values = split (/\0/, $parms{$parmKey});
1872          # Check for special cases.          # Check for special cases.
1873          if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF ShowURL)) {          if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) {
1874              # These are bookkeeping parameters we don't need to start a search.              # These are bookkeeping parameters we don't need to start a search.
1875              @values = ();              @values = ();
1876          } elsif ($parmKey =~ /_SearchThing$/) {          } elsif ($parmKey =~ /_SearchThing$/) {
# Line 2143  Line 2245 
2245                      if ($hasChildren) {                      if ($hasChildren) {
2246                          Trace("Processing children of $myLabel.") if T(4);                          Trace("Processing children of $myLabel.") if T(4);
2247                          push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');                          push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2248                            Trace("Children of $myLabel finished.") if T(4);
2249                      }                      }
2250                  }                  }
2251              }              }
# Line 2177  Line 2280 
2280              }              }
2281              # Next, we format the label.              # Next, we format the label.
2282              my $labelHtml = $myLabel;              my $labelHtml = $myLabel;
2283              Trace("Formatting tree node for $myLabel.") if T(4);              Trace("Formatting tree node for \"$myLabel\".") if T(4);
2284              # Apply a hyperlink if necessary.              # Apply a hyperlink if necessary.
2285              if (defined $attrHash->{link}) {              if (defined $attrHash->{link}) {
2286                  $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },                  $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
# Line 2237  Line 2340 
2340  the name for the protein page link column is C<protlink>. If the column is to appear  the name for the protein page link column is C<protlink>. If the column is to appear
2341  in the default list of feature columns, add it to the list returned by  in the default list of feature columns, add it to the list returned by
2342  L</DefaultFeatureColumns>. Then add code to produce the column title to  L</DefaultFeatureColumns>. Then add code to produce the column title to
2343  L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>, and  L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>. If the
2344  everything else will happen automatically.  feature column should be excluded from downloads, add it to the C<FeatureColumnSkip>
2345    hash. Everything else will happen automatically.
2346    
2347  There is one special column name syntax for extra columns (that is, nonstandard  There is a special column name syntax for extra columns (that is, nonstandard
2348  feature columns). If the column name begins with C<X=>, then it is presumed to be  feature columns). If the column name begins with C<X=>, then it is presumed to be
2349  an extra column. The column title is the text after the C<X=>, and its value is  an extra column. The column title is the text after the C<X=>, and its value is
2350  pulled from the extra column hash.  pulled from the extra column hash.
2351    
2352    =cut
2353    
2354    # This hash is used to determine which columns should not be included in downloads.
2355    my %FeatureColumnSkip = map { $_ => 1 } qw(gblink viewerlink protlink);
2356    
2357  =head3 DefaultFeatureColumns  =head3 DefaultFeatureColumns
2358    
2359  C<< my @colNames = $shelp->DefaultFeatureColumns(); >>  C<< my @colNames = $shelp->DefaultFeatureColumns(); >>
# Line 2307  Line 2416 
2416          $retVal = "Organism and Gene ID";          $retVal = "Organism and Gene ID";
2417      } elsif ($colName eq 'protlink') {      } elsif ($colName eq 'protlink') {
2418          $retVal = "NMPDR Protein Page";          $retVal = "NMPDR Protein Page";
2419        } elsif ($colName eq 'viewerlink') {
2420            $retVal = "Annotation Page";
2421      } elsif ($colName eq 'subsystem') {      } elsif ($colName eq 'subsystem') {
2422          $retVal = "Subsystems";          $retVal = "Subsystems";
2423      }      }
# Line 2314  Line 2425 
2425      return $retVal;      return $retVal;
2426  }  }
2427    
2428    =head3 FeatureColumnDownload
2429    
2430    C<< my $keep = $shelp->FeatureColumnDownload($colName); >>
2431    
2432    Return TRUE if the named feature column is to be kept when downloading, else FALSE.
2433    
2434    =over 4
2435    
2436    =item colName
2437    
2438    Name of the relevant feature column.
2439    
2440    =item RETURN
2441    
2442    Return TRUE if the named column should be kept while downloading, else FALSE. In general,
2443    FALSE is returned if the column generates a button, image, or other purely-HTML value.
2444    
2445    =back
2446    
2447    =cut
2448    
2449    sub FeatureColumnDownload {
2450        # Get the parameters.
2451        my ($self, $colName) = @_;
2452        # Return the determination. We download the column if it's not in the skip-hash.
2453        # Note we return 0 and 1 instead of 1 and undef because it simplifies some tracing.
2454        return (exists $FeatureColumnSkip{$colName} ? 0 : 1);
2455    }
2456    
2457    
2458  =head3 FeatureColumnValue  =head3 FeatureColumnValue
2459    
# Line 2329  Line 2469 
2469    
2470  =item record  =item record
2471    
2472  DBObject record for the feature being displayed in the current row.  ERDBObject record for the feature being displayed in the current row.
2473    
2474  =item extraCols  =item extraCols
2475    
# Line 2368  Line 2508 
2508      } elsif ($colName eq 'alias') {      } elsif ($colName eq 'alias') {
2509          # 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.
2510          # 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.
2511          $retVal = "%%alias=$fid";          # To do the computation, we need to know the favored alias type and the
2512            # feature ID.
2513            my $favored = $cgi->param("FavoredAlias") || "fig";
2514            $retVal = "%%alias=$fid,$favored";
2515      } elsif ($colName eq 'fid') {      } elsif ($colName eq 'fid') {
2516          # Here we have the raw feature ID. We hyperlink it to the protein page.          # Here we have the raw feature ID. We hyperlink it to the protein page.
2517          $retVal = HTML::set_prot_links($fid);          $retVal = HTML::set_prot_links($fid);
# Line 2377  Line 2520 
2520          ($retVal) = $record->Value('Feature(assignment)');          ($retVal) = $record->Value('Feature(assignment)');
2521      } elsif ($colName eq 'gblink') {      } elsif ($colName eq 'gblink') {
2522          # Here we want a link to the GBrowse page using the official GBrowse button.          # Here we want a link to the GBrowse page using the official GBrowse button.
2523          $retVal = Formlet('GBrowse', "GetGBrowse.cgi", undef,          $retVal = FakeButton('GBrowse', "GetGBrowse.cgi", undef,
2524                            fid => $fid);                            fid => $fid);
2525      } elsif ($colName eq 'group') {      } elsif ($colName eq 'group') {
2526          # Get the NMPDR group name.          # Get the NMPDR group name.
# Line 2395  Line 2538 
2538          $retVal = $self->FeatureName($fid);          $retVal = $self->FeatureName($fid);
2539      } elsif ($colName eq 'protlink') {      } elsif ($colName eq 'protlink') {
2540          # 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.
2541          $retVal = Formlet('NMPDR', "protein.cgi", undef,          $retVal = FakeButton('NMPDR', "protein.cgi", undef,
2542                            prot => $fid, SPROUT => 1, new_framework => 0,                            prot => $fid, SPROUT => 1, new_framework => 0,
2543                            user => '');                            user => '');
2544        } elsif ($colName eq 'viewerlink') {
2545            # Here we want a link to the SEED viewer page using the official viewer button.
2546            $retVal = FakeButton('Annotation', "index.cgi", undef,
2547                                 action => 'ShowAnnotation', prot => $fid);
2548      }elsif ($colName eq 'subsystem') {      }elsif ($colName eq 'subsystem') {
2549          # Another run-time column: subsystem list.          # Another run-time column: subsystem list.
2550          $retVal = "%%subsystem=$fid";          $retVal = "%%subsystem=$fid";
# Line 2443  Line 2590 
2590      # Separate the text into a type and data.      # Separate the text into a type and data.
2591      if ($type eq 'alias') {      if ($type eq 'alias') {
2592          # Here the caller wants external alias links for a feature. The text          # Here the caller wants external alias links for a feature. The text
2593          # is the feature ID.          # parameter for computing the alias is the feature ID followed by
2594          my $fid = $text;          # the favored alias type.
2595          # The complicated part is we have to hyperlink them. First, get the          my ($fid, $favored) = split /\s*,\s*/, $text;
2596          # aliases.          # The complicated part is we have to hyperlink them and handle the
2597            # favorites. First, get the aliases.
2598          Trace("Generating aliases for feature $fid.") if T(4);          Trace("Generating aliases for feature $fid.") if T(4);
2599          my @aliases = $sprout->FeatureAliases($fid);          my @aliases = sort $sprout->FeatureAliases($fid);
2600          # Only proceed if we found some.          # Only proceed if we found some.
2601          if (@aliases) {          if (@aliases) {
2602              # Join the aliases into a comma-delimited list.              # Split the aliases into favored and unfavored.
2603              my $aliasList = join(", ", @aliases);              my @favored = ();
2604                my @unfavored = ();
2605                for my $alias (@aliases) {
2606                    # Use substr instead of pattern match because $favored is specified by the user
2607                    # and we don't want him to put funny meta-characters in there.
2608                    if (substr($alias, 0, length($favored)) eq $favored) {
2609                        push @favored, $alias;
2610                    } else {
2611                        push @unfavored, $alias;
2612                    }
2613                }
2614                # Rejoin the aliases into a comma-delimited list, with the favored ones first.
2615                my $aliasList = join(", ", @favored, @unfavored);
2616              # Ask the HTML processor to hyperlink them.              # Ask the HTML processor to hyperlink them.
2617              $retVal = HTML::set_prot_links($cgi, $aliasList);              $retVal = HTML::set_prot_links($cgi, $aliasList);
2618          }          }
# Line 2601  Line 2761 
2761      return $retVal;      return $retVal;
2762  }  }
2763    
2764    =head3 FakeButton
2765    
2766    C<< my $html = SearchHelper::FakeButton($caption, $url, $target, %parms); >>
2767    
2768    Create a fake button that hyperlinks to the specified URL with the specified parameters.
2769    Unlike a real button, this one won't visibly click, but it will take the user to the
2770    correct place.
2771    
2772    The parameters of this method are deliberately identical to L</Formlet> so that we
2773    can switch easily from real buttons to fake ones in the code.
2774    
2775    =over 4
2776    
2777    =item caption
2778    
2779    Caption to be put on the button.
2780    
2781    =item url
2782    
2783    URL for the target page or script.
2784    
2785    =item target
2786    
2787    Frame or target in which the new page should appear. If C<undef> is specified,
2788    the default target will be used.
2789    
2790    =item parms
2791    
2792    Hash containing the parameter names as keys and the parameter values as values.
2793    These will be appended to the URL.
2794    
2795    =back
2796    
2797    =cut
2798    
2799    sub FakeButton {
2800        # Get the parameters.
2801        my ($caption, $url, $target, %parms) = @_;
2802        # Declare the return variable.
2803        my $retVal;
2804        # Compute the target URL.
2805        my $targetUrl = "$url?" . join(";", map { "$_=" . uri_escape($parms{$_}) } keys %parms);
2806        # Compute the target-frame HTML.
2807        my $targetHtml = ($target ? " target=\"$target\"" : "");
2808        # Assemble the result.
2809        return "<a href=\"$targetUrl\" $targetHtml><div class=\"button2 button\">$caption</div></a>";
2810    }
2811    
2812  =head3 Formlet  =head3 Formlet
2813    
2814  C<< my $html = SearchHelper::Formlet($caption, $url, $target, %parms); >>  C<< my $html = SearchHelper::Formlet($caption, $url, $target, %parms); >>
# Line 2717  Line 2925 
2925      return $retVal;      return $retVal;
2926  }  }
2927    
2928    =head3 PrintLine
2929    
2930    C<< $shelp->PrintLine($message); >>
2931    
2932    Print a line of CGI output. This is used during the operation of the B<Find> method while
2933    searching, so the user sees progress in real-time.
2934    
2935    =over 4
2936    
2937    =item message
2938    
2939    HTML text to display.
2940    
2941    =back
2942    
2943    =cut
2944    
2945    sub PrintLine {
2946        # Get the parameters.
2947        my ($self, $message) = @_;
2948        # Send them to the output.
2949        print "$message\n";
2950    }
2951    
2952    
2953  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3