[Bio] / Sprout / Sprout.pm Repository:
ViewVC logotype

Diff of /Sprout/Sprout.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3, Tue Jan 25 01:00:20 2005 UTC revision 1.12, Wed May 4 03:24:43 2005 UTC
# Line 36  Line 36 
36    
37  #: Constructor SFXlate->new_sprout_only();  #: Constructor SFXlate->new_sprout_only();
38    
   
39  =head2 Public Methods  =head2 Public Methods
40    
41  =head3 new  =head3 new
# Line 125  Line 124 
124  =cut  =cut
125  #: Return Type $;  #: Return Type $;
126  sub MaxSegment {  sub MaxSegment {
127          my $self = shift @_;          my ($self) = @_;
128          return $self->{_options}->{maxSegmentLength};          return $self->{_options}->{maxSegmentLength};
129  }  }
130    
# Line 140  Line 139 
139  =cut  =cut
140  #: Return Type $;  #: Return Type $;
141  sub MaxSequence {  sub MaxSequence {
142          my $self = shift @_;          my ($self) = @_;
143          return $self->{_options}->{maxSequenceLength};          return $self->{_options}->{maxSequenceLength};
144  }  }
145    
# Line 233  Line 232 
232    
233  sub Get {  sub Get {
234          # Get the parameters.          # Get the parameters.
235          my $self = shift @_;          my ($self, $objectNames, $filterClause, $parameterList) = @_;
         my ($objectNames, $filterClause, $parameterList) = @_;  
236          # We differ from the ERDB Get method in that the parameter list is passed in as a list reference          # We differ from the ERDB Get method in that the parameter list is passed in as a list reference
237          # rather than a list of parameters. The next step is to convert the parameters from a reference          # rather than a list of parameters. The next step is to convert the parameters from a reference
238          # to a real list. We can only do this if the parameters have been specified.          # to a real list. We can only do this if the parameters have been specified.
# Line 270  Line 268 
268    
269  sub GetEntity {  sub GetEntity {
270          # Get the parameters.          # Get the parameters.
271          my $self = shift @_;          my ($self, $entityType, $ID) = @_;
272          my ($entityType, $ID) = @_;          # Call the ERDB method.
273          # Create a query.          return $self->{_erdb}->GetEntity($entityType, $ID);
         my $query = $self->Get([$entityType], "$entityType(id) = ?", [$ID]);  
         # Get the first (and only) object.  
         my $retVal = $query->Fetch();  
         # Return the result.  
         return $retVal;  
274  }  }
275    
276  =head3 GetEntityValues  =head3 GetEntityValues
# Line 310  Line 303 
303  #: Return Type @;  #: Return Type @;
304  sub GetEntityValues {  sub GetEntityValues {
305          # Get the parameters.          # Get the parameters.
306          my $self = shift @_;          my ($self, $entityType, $ID, $fields) = @_;
307          my ($entityType, $ID, $fields) = @_;          # Call the ERDB method.
308          # Get the specified entity.          return $self->{_erdb}->GetEntityValues($entityType, $ID, $fields);
         my $entity = $self->GetEntity($entityType, $ID);  
         # Declare the return list.  
         my @retVal = ();  
         # If we found the entity, push the values into the return list.  
         if ($entity) {  
                 push @retVal, $entity->Values($fields);  
         }  
         # Return the result.  
         return @retVal;  
309  }  }
310    
311  =head3 ShowMetaData  =head3 ShowMetaData
# Line 342  Line 326 
326    
327  sub ShowMetaData {  sub ShowMetaData {
328          # Get the parameters.          # Get the parameters.
329          my $self = shift @_;          my ($self, $fileName) = @_;
         my ($fileName) = @_;  
330          # Compute the file name.          # Compute the file name.
331          my $options = $self->{_options};          my $options = $self->{_options};
332          # Call the show method on the underlying ERDB object.          # Call the show method on the underlying ERDB object.
# Line 383  Line 366 
366  #: Return Type %;  #: Return Type %;
367  sub Load {  sub Load {
368          # Get the parameters.          # Get the parameters.
369          my $self = shift @_;          my ($self, $rebuild) = @_;
         my ($rebuild) = @_;  
370          # Get the database object.          # Get the database object.
371          my $erdb = $self->{_erdb};          my $erdb = $self->{_erdb};
372          # Load the tables from the data directory.          # Load the tables from the data directory.
# Line 424  Line 406 
406  =back  =back
407    
408  =cut  =cut
409  #: Return Type %;  #: Return Type $%;
410  sub LoadUpdate {  sub LoadUpdate {
411          # Get the parameters.          # Get the parameters.
412          my $self = shift @_;          my ($self, $truncateFlag, $tableList) = @_;
         my ($truncateFlag, $tableList) = @_;  
413          # Get the database object.          # Get the database object.
414          my $erdb = $self->{_erdb};          my $erdb = $self->{_erdb};
415          # Declare the return value.          # Declare the return value.
# Line 464  Line 445 
445  #: Return Type ;  #: Return Type ;
446  sub Build {  sub Build {
447          # Get the parameters.          # Get the parameters.
448          my $self = shift @_;          my ($self) = @_;
449          # Create the tables.          # Create the tables.
450          $self->{_erdb}->CreateTables;          $self->{_erdb}->CreateTables;
451  }  }
# Line 479  Line 460 
460  #: Return Type @;  #: Return Type @;
461  sub Genomes {  sub Genomes {
462          # Get the parameters.          # Get the parameters.
463          my $self = shift @_;          my ($self) = @_;
464          # Get all the genomes.          # Get all the genomes.
465          my @retVal = $self->GetFlat(['Genome'], "", [], 'Genome(id)');          my @retVal = $self->GetFlat(['Genome'], "", [], 'Genome(id)');
466          # Return the list of IDs.          # Return the list of IDs.
# Line 509  Line 490 
490  #: Return Type $;  #: Return Type $;
491  sub GenusSpecies {  sub GenusSpecies {
492          # Get the parameters.          # Get the parameters.
493          my $self = shift @_;          my ($self, $genomeID) = @_;
         my ($genomeID) = @_;  
494          # Get the data for the specified genome.          # Get the data for the specified genome.
495          my @values = $self->GetEntityValues('Genome', $genomeID, ['Genome(genus)', 'Genome(species)',          my @values = $self->GetEntityValues('Genome', $genomeID, ['Genome(genus)', 'Genome(species)',
496                                                                                                                            'Genome(unique-characterization)']);                                                                                                                            'Genome(unique-characterization)']);
# Line 546  Line 526 
526  #: Return Type @;  #: Return Type @;
527  sub FeaturesOf {  sub FeaturesOf {
528          # Get the parameters.          # Get the parameters.
529          my $self = shift @_;          my ($self, $genomeID,$ftype) = @_;
         my ($genomeID,$ftype) = @_;  
530          # Get the features we want.          # Get the features we want.
531          my @features;          my @features;
532          if (!$ftype) {          if (!$ftype) {
# Line 600  Line 579 
579  #: Return Type $;  #: Return Type $;
580  sub FeatureLocation {  sub FeatureLocation {
581          # Get the parameters.          # Get the parameters.
582          my $self = shift @_;          my ($self, $featureID) = @_;
         my ($featureID) = @_;  
583          # Create a query for the feature locations.          # Create a query for the feature locations.
584          my $query = $self->Get(['IsLocatedIn'], "IsLocatedIn(from-link) = ? ORDER BY IsLocatedIn(locN)",          my $query = $self->Get(['IsLocatedIn'], "IsLocatedIn(from-link) = ? ORDER BY IsLocatedIn(locN)",
585                                                     [$featureID]);                                                     [$featureID]);
# Line 661  Line 639 
639  =cut  =cut
640  #: Return Type @;  #: Return Type @;
641  sub ParseLocation {  sub ParseLocation {
642          # Get the parameter.          # Get the parameter. Note that if we're called as an instance method, we ignore
643        # the first parameter.
644        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
645          my ($location) = @_;          my ($location) = @_;
646          # Parse it into segments.          # Parse it into segments.
647          $location =~ /^(.*)_(\d*)([+-_])(\d*)$/;          $location =~ /^(.*)_(\d*)([+-_])(\d*)$/;
# Line 680  Line 660 
660          return ($contigID, $start, $dir, $len);          return ($contigID, $start, $dir, $len);
661  }  }
662    
663    =head3 PointLocation
664    
665    C<< my $found = Sprout::PointLocation($location, $point); >>
666    
667    Return the offset into the specified location of the specified point on the contig. If
668    the specified point is before the location, a negative value will be returned. If it is
669    beyond the location, an undefined value will be returned. It is assumed that the offset
670    is for the location's contig. The location can either be new-style (using a C<+> or C<->
671    and a length) or old-style (using C<_> and start and end positions.
672    
673    =over 4
674    
675    =item location
676    
677    A location specifier (see L</FeatureLocation> for a description).
678    
679    =item point
680    
681    The offset into the contig of the point in which we're interested.
682    
683    =item RETURN
684    
685    Returns the offset inside the specified location of the specified point, a negative
686    number if the point is before the location, or an undefined value if the point is past
687    the location. If the length of the location is 0, this method will B<always> denote
688    that it is outside the location. The offset will always be relative to the left-most
689    position in the location.
690    
691    =back
692    
693    =cut
694    #: Return Type $;
695    sub PointLocation {
696            # Get the parameter. Note that if we're called as an instance method, we ignore
697        # the first parameter.
698        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
699            my ($location, $point) = @_;
700        # Parse out the location elements. Note that this works on both old-style and new-style
701        # locations.
702        my ($contigID, $start, $dir, $len) = ParseLocation($location);
703        # Declare the return variable.
704        my $retVal;
705        # Compute the offset. The computation is dependent on the direction of the location.
706        my $offset = (($dir == '+') ? $point - $start : $point - ($start - $len + 1));
707        # Return the offset if it's valid.
708        if ($offset < $len) {
709            $retVal = $offset;
710        }
711        # Return the offset found.
712        return $retVal;
713    }
714    
715  =head3 DNASeq  =head3 DNASeq
716    
717  C<< my $sequence = $sprout->DNASeq(\@locationList); >>  C<< my $sequence = $sprout->DNASeq(\@locationList); >>
# Line 705  Line 737 
737  #: Return Type $;  #: Return Type $;
738  sub DNASeq {  sub DNASeq {
739          # Get the parameters.          # Get the parameters.
740          my $self = shift @_;          my ($self, $locationList) = @_;
         my ($locationList) = @_;  
741          # Create the return string.          # Create the return string.
742          my $retVal = "";          my $retVal = "";
743          # Loop through the locations.          # Loop through the locations.
# Line 779  Line 810 
810  #: Return Type @;  #: Return Type @;
811  sub AllContigs {  sub AllContigs {
812          # Get the parameters.          # Get the parameters.
813          my $self = shift @_;          my ($self, $genomeID) = @_;
         my ($genomeID) = @_;  
814          # Ask for the genome's Contigs.          # Ask for the genome's Contigs.
815          my @retVal = $self->GetFlat(['HasContig'], "HasContig(from-link) = ?", [$genomeID],          my @retVal = $self->GetFlat(['HasContig'], "HasContig(from-link) = ?", [$genomeID],
816                                                                  'HasContig(to-link)');                                                                  'HasContig(to-link)');
# Line 810  Line 840 
840  #: Return Type $;  #: Return Type $;
841  sub ContigLength {  sub ContigLength {
842          # Get the parameters.          # Get the parameters.
843          my $self = shift @_;          my ($self, $contigID) = @_;
         my ($contigID) = @_;  
844          # Get the contig's last sequence.          # Get the contig's last sequence.
845          my $query = $self->Get(['IsMadeUpOf'],          my $query = $self->Get(['IsMadeUpOf'],
846                  "IsMadeUpOf(from-link) = ? ORDER BY IsMadeUpOf(start-position) DESC",                  "IsMadeUpOf(from-link) = ? ORDER BY IsMadeUpOf(start-position) DESC",
# Line 853  Line 882 
882  Returns a three-element list. The first element is a list of feature IDs for the features that  Returns a three-element list. The first element is a list of feature IDs for the features that
883  overlap the region of interest. The second and third elements are the minimum and maximum  overlap the region of interest. The second and third elements are the minimum and maximum
884  locations of the features provided on the specified contig. These may extend outside  locations of the features provided on the specified contig. These may extend outside
885  the start and stop values.  the start and stop values. The first element (that is, the list of features) is sorted
886    roughly by location.
887    
888  =back  =back
889    
890  =cut  =cut
891  #: Return Type @;  #: Return Type @@;
892  sub GenesInRegion {  sub GenesInRegion {
893          # Get the parameters.          # Get the parameters.
894          my $self = shift @_;          my ($self, $contigID, $start, $stop) = @_;
         my ($contigID, $start, $stop) = @_;  
895          # Get the maximum segment length.          # Get the maximum segment length.
896          my $maximumSegmentLength = $self->MaxSegment;          my $maximumSegmentLength = $self->MaxSegment;
897          # Create a hash to receive the feature list. We use a hash so that we can eliminate          # Create a hash to receive the feature list. We use a hash so that we can eliminate
898          # duplicates easily.          # duplicates easily. The hash key will be the feature ID. The value will be a two-element
899            # containing the minimum and maximum offsets. We will use the offsets to sort the results
900            # when we're building the result set.
901          my %featuresFound = ();          my %featuresFound = ();
902          # Prime the values we'll use for the returned beginning and end.          # Prime the values we'll use for the returned beginning and end.
903          my ($min, $max) = ($self->ContigLength($contigID), 0);          my @initialMinMax = ($self->ContigLength($contigID), 0);
904            my ($min, $max) = @initialMinMax;
905          # Create a table of parameters for each query. Each query looks for features travelling in          # Create a table of parameters for each query. Each query looks for features travelling in
906          # a particular direction. The query parameters include the contig ID, the feature direction,          # a particular direction. The query parameters include the contig ID, the feature direction,
907          # the lowest possible start position, and the highest possible start position. This works          # the lowest possible start position, and the highest possible start position. This works
# Line 899  Line 931 
931                                          $found = 1;                                          $found = 1;
932                                  }                                  }
933                          } elsif ($dir eq '-') {                          } elsif ($dir eq '-') {
934                                  $end = $beg - $len;                                  # Note we switch things around so that the beginning is to the left of the
935                                  if ($end <= $stop) {                                  # ending.
936                                    ($beg, $end) = ($beg - $len, $beg);
937                                    if ($beg <= $stop) {
938                                          # Denote we found a useful feature.                                          # Denote we found a useful feature.
939                                          $found = 1;                                          $found = 1;
940                                  }                                  }
941                          }                          }
942                          if ($found) {                          if ($found) {
943                                  # Here we need to record the feature and update the minimum and maximum.                                  # Here we need to record the feature and update the minima and maxima. First,
944                                  $featuresFound{$featureID} = 1;                                  # get the current entry for the specified feature.
945                                  if ($beg < $min) { $min = $beg; }                                  my ($loc1, $loc2) = (exists $featuresFound{$featureID} ? @{$featuresFound{$featureID}} :
946                                  if ($end < $min) { $min = $end; }                                                                           @initialMinMax);
947                                  if ($beg > $max) { $max = $beg; }                                  # Merge the current segment's begin and end into the feature begin and end and the
948                                  if ($end > $max) { $max = $end; }                                  # global min and max.
949                                    if ($beg < $loc1) {
950                                            $loc1 = $beg;
951                                            $min = $beg if $beg < $min;
952                                    }
953                                    if ($end > $loc2) {
954                                            $loc2 = $end;
955                                            $max = $end if $end > $max;
956                                    }
957                                    # Store the entry back into the hash table.
958                                    $featuresFound{$featureID} = [$loc1, $loc2];
959                          }                          }
960                  }                  }
961          }          }
962          # Compute a list of the IDs for the features found.          # Now we must compute the list of the IDs for the features found. We start with a list
963          my @list = (sort (keys %featuresFound));          # of midpoints / feature ID pairs. (It's not really a midpoint, it's twice the midpoint,
964            # but the result of the sort will be the same.)
965            my @list = map { [$featuresFound{$_}->[0] + $featuresFound{$_}->[1], $_] } keys %featuresFound;
966            # Now we sort by midpoint and yank out the feature IDs.
967            my @retVal = map { $_->[1] } sort { $a->[0] <=> $b->[0] } @list;
968          # Return it along with the min and max.          # Return it along with the min and max.
969          return (\@list, $min, $max);          return (\@retVal, $min, $max);
970  }  }
971    
972  =head3 FType  =head3 FType
# Line 944  Line 992 
992  #: Return Type $;  #: Return Type $;
993  sub FType {  sub FType {
994          # Get the parameters.          # Get the parameters.
995          my $self = shift @_;          my ($self, $featureID) = @_;
         my ($featureID) = @_;  
996          # Get the specified feature's type.          # Get the specified feature's type.
997          my ($retVal) = $self->GetEntityValues('Feature', $featureID, ['Feature(feature-type)']);          my ($retVal) = $self->GetEntityValues('Feature', $featureID, ['Feature(feature-type)']);
998          # Return the result.          # Return the result.
# Line 982  Line 1029 
1029  #: Return Type @%;  #: Return Type @%;
1030  sub FeatureAnnotations {  sub FeatureAnnotations {
1031          # Get the parameters.          # Get the parameters.
1032          my $self = shift @_;          my ($self, $featureID) = @_;
         my ($featureID) = @_;  
1033          # Create a query to get the feature's annotations and the associated users.          # Create a query to get the feature's annotations and the associated users.
1034          my $query = $self->Get(['IsTargetOfAnnotation', 'Annotation', 'MadeAnnotation'],          my $query = $self->Get(['IsTargetOfAnnotation', 'Annotation', 'MadeAnnotation'],
1035                                                     "IsTargetOfAnnotation(from-link) = ?", [$featureID]);                                                     "IsTargetOfAnnotation(from-link) = ?", [$featureID]);
# Line 1012  Line 1058 
1058  C<< my %functions = $sprout->AllFunctionsOf($featureID); >>  C<< my %functions = $sprout->AllFunctionsOf($featureID); >>
1059    
1060  Return all of the functional assignments for a particular feature. The data is returned as a  Return all of the functional assignments for a particular feature. The data is returned as a
1061  hash of functional assignments to user IDs. A functional assignment is a type of annotation.  hash of functional assignments to user IDs. A functional assignment is a type of annotation,
1062  It has the format "XXXX\nset XXXX function to\nYYYYY". In this instance, XXXX is the user ID  Functional assignments are described in the L</ParseAssignment> function. Its worth noting that
1063  and YYYYY is the functional assignment text. Its worth noting that we cannot filter on the content  we cannot filter on the content of the annotation itself because it's a text field; however,
1064  of the annotation itself because it's a text field; however, this is not a big problem because most  this is not a big problem because most features only have a small number of annotations.
1065  features only have a small number of annotations.  Finally, if a single user has multiple functional assignments, we will only keep the most
1066    recent one.
1067    
1068  =over 4  =over 4
1069    
# Line 1034  Line 1081 
1081  #: Return Type %;  #: Return Type %;
1082  sub AllFunctionsOf {  sub AllFunctionsOf {
1083          # Get the parameters.          # Get the parameters.
1084          my $self = shift @_;          my ($self, $featureID) = @_;
         my ($featureID) = @_;  
1085          # Get all of the feature's annotations.          # Get all of the feature's annotations.
1086          my @query = $self->GetFlat(['IsTargetOfAnnotation', 'Annotation'],      my @query = $self->GetAll(['IsTargetOfAnnotation', 'Annotation'],
1087                                                      "IsTargetOfAnnotation(from-link) = ?",                                                      "IsTargetOfAnnotation(from-link) = ?",
1088                                                          [$featureID], 'Annotation(annotation)');                              [$featureID], ['Annotation(time)', 'Annotation(annotation)']);
1089          # Declare the return hash.          # Declare the return hash.
1090          my %retVal;          my %retVal;
1091        # Declare a hash for insuring we only make one assignment per user.
1092        my %timeHash = ();
1093        # Now we sort the assignments by timestamp in reverse.
1094        my @sortedQuery = sort { -($a->[0] <=> $b->[0]) } @query;
1095          # Loop until we run out of annotations.          # Loop until we run out of annotations.
1096          for my $text (@query) {      for my $annotation (@sortedQuery) {
1097            # Get the annotation fields.
1098            my ($timeStamp, $text) = @{$annotation};
1099                  # Check to see if this is a functional assignment.                  # Check to see if this is a functional assignment.
1100                  my ($user, $function) = ParseAssignment($text);                  my ($user, $function) = _ParseAssignment($text);
1101                  if ($user) {          if ($user && ! exists $timeHash{$user}) {
1102                          # Here it is, so stuff it in the return hash.              # Here it is a functional assignment and there has been no
1103                # previous assignment for this user, so we stuff it in the
1104                # return hash.
1105                          $retVal{$function} = $user;                          $retVal{$function} = $user;
1106                # Insure we don't assign to this user again.
1107                $timeHash{$user} = 1;
1108                  }                  }
1109          }          }
1110          # Return the hash of assignments found.          # Return the hash of assignments found.
# Line 1063  Line 1119 
1119    
1120  The functional assignment is handled differently depending on the type of feature. If  The functional assignment is handled differently depending on the type of feature. If
1121  the feature is identified by a FIG ID (begins with the string C<fig|>), then a functional  the feature is identified by a FIG ID (begins with the string C<fig|>), then a functional
1122  assignment is a type of annotation. It has the format "XXXX\nset XXXX function to\nYYYYY". In this  assignment is a type of annotation. The format of an assignment is described in
1123  instance, XXXX is the user ID and YYYYY is the functional assignment text. Its worth noting that  L</ParseLocation>. Its worth noting that we cannot filter on the content of the
1124  we cannot filter on the content of the annotation itself because it's a text field; however, this  annotation itself because it's a text field; however, this is not a big problem because
1125  is not a big problem because most features only have a small number of annotations.  most features only have a small number of annotations.
1126    
1127  Each user has an associated list of trusted users. The assignment returned will be the most  Each user has an associated list of trusted users. The assignment returned will be the most
1128  recent one by at least one of the trusted users. If no trusted user list is available, then  recent one by at least one of the trusted users. If no trusted user list is available, then
# Line 1098  Line 1154 
1154  #: Return Type $;  #: Return Type $;
1155  sub FunctionOf {  sub FunctionOf {
1156          # Get the parameters.          # Get the parameters.
1157          my $self = shift @_;          my ($self, $featureID, $userID) = @_;
         my ($featureID, $userID) = @_;  
1158      # Declare the return value.      # Declare the return value.
1159      my $retVal;      my $retVal;
1160      # Determine the ID type.      # Determine the ID type.
# Line 1136  Line 1191 
1191              # Get the annotation text.              # Get the annotation text.
1192              my ($text, $time) = $annotation->Values(['Annotation(annotation)','Annotation(time)']);              my ($text, $time) = $annotation->Values(['Annotation(annotation)','Annotation(time)']);
1193              # Check to see if this is a functional assignment for a trusted user.              # Check to see if this is a functional assignment for a trusted user.
1194              my ($user, $type, $function) = split(/\n/, $text);              my ($user, $function) = _ParseAssignment($text);
1195              if ($type =~ m/^set $user function to$/i) {              if ($user) {
1196                  # Here it is a functional assignment. Check the time and the user                  # Here it is a functional assignment. Check the time and the user
1197                  # name. The time must be recent and the user must be trusted.                  # name. The time must be recent and the user must be trusted.
1198                  if ((exists $trusteeTable{$user}) && ($time > $timeSelected)) {                  if ((exists $trusteeTable{$user}) && ($time > $timeSelected)) {
# Line 1150  Line 1205 
1205          # Here we have a non-FIG feature ID. In this case the user ID does not          # Here we have a non-FIG feature ID. In this case the user ID does not
1206          # matter. We simply get the information from the External Alias Function          # matter. We simply get the information from the External Alias Function
1207          # table.          # table.
1208          ($retVal) = $self->GetEntityValues('ExternalAliasFunc', $featureID, ['func']);          ($retVal) = $self->GetEntityValues('ExternalAliasFunc', $featureID, ['ExternalAliasFunc(func)']);
1209      }      }
1210          # Return the assignment found.          # Return the assignment found.
1211          return $retVal;          return $retVal;
# Line 1184  Line 1239 
1239  #: Return Type %;  #: Return Type %;
1240  sub BBHList {  sub BBHList {
1241          # Get the parameters.          # Get the parameters.
1242          my $self = shift @_;          my ($self, $genomeID, $featureList) = @_;
         my ($genomeID, $featureList) = @_;  
1243          # Create the return structure.          # Create the return structure.
1244          my %retVal = ();          my %retVal = ();
1245          # Loop through the incoming features.          # Loop through the incoming features.
# Line 1228  Line 1282 
1282  #: Return Type @;  #: Return Type @;
1283  sub FeatureAliases {  sub FeatureAliases {
1284          # Get the parameters.          # Get the parameters.
1285          my $self = shift @_;          my ($self, $featureID) = @_;
         my ($featureID) = @_;  
1286          # Get the desired feature's aliases          # Get the desired feature's aliases
1287          my @retVal = $self->GetEntityValues('Feature', $featureID, ['Feature(alias)']);          my @retVal = $self->GetEntityValues('Feature', $featureID, ['Feature(alias)']);
1288          # Return the result.          # Return the result.
# Line 1259  Line 1312 
1312  #: Return Type $;  #: Return Type $;
1313  sub GenomeOf {  sub GenomeOf {
1314          # Get the parameters.          # Get the parameters.
1315          my $self = shift @_;          my ($self, $featureID) = @_;
         my ($featureID) = @_;  
1316          # Create a query to find the genome associated with the feature.          # Create a query to find the genome associated with the feature.
1317          my $query = $self->Get(['IsLocatedIn', 'HasContig'], "IsLocatedIn(from-link) = ?", [$featureID]);          my $query = $self->Get(['IsLocatedIn', 'HasContig'], "IsLocatedIn(from-link) = ?", [$featureID]);
1318          # Declare the return value.          # Declare the return value.
# Line 1296  Line 1348 
1348  #: Return Type %;  #: Return Type %;
1349  sub CoupledFeatures {  sub CoupledFeatures {
1350          # Get the parameters.          # Get the parameters.
1351          my $self = shift @_;          my ($self, $featureID) = @_;
         my ($featureID) = @_;  
1352          # Create a query to retrieve the functionally-coupled features. Note that we depend on the          # Create a query to retrieve the functionally-coupled features. Note that we depend on the
1353          # fact that the functional coupling is physically paired. If (A,B) is in the database, then          # fact that the functional coupling is physically paired. If (A,B) is in the database, then
1354          # (B,A) will also be found.          # (B,A) will also be found.
# Line 1333  Line 1384 
1384  #: Return Type @;  #: Return Type @;
1385  sub GetEntityTypes {  sub GetEntityTypes {
1386          # Get the parameters.          # Get the parameters.
1387          my $self = shift @_;          my ($self) = @_;
1388          # Get the underlying database object.          # Get the underlying database object.
1389          my $erdb = $self->{_erdb};          my $erdb = $self->{_erdb};
1390          # Get its entity type list.          # Get its entity type list.
# Line 1384  Line 1435 
1435                  if ($line =~ m/^>\s*(.+?)(\s|\n)/) {                  if ($line =~ m/^>\s*(.+?)(\s|\n)/) {
1436                          # Here we have a new header. Store the current sequence if we have one.                          # Here we have a new header. Store the current sequence if we have one.
1437                          if ($id) {                          if ($id) {
1438                                  $retVal{$id} = $sequence;                                  $retVal{$id} = uc $sequence;
1439                          }                          }
1440                          # Clear the sequence accumulator and save the new ID.                          # Clear the sequence accumulator and save the new ID.
1441                          ($id, $sequence) = ("$prefix$1", "");                          ($id, $sequence) = ("$prefix$1", "");
1442                  } else {                  } else {
1443                          # Here we have a data line, so we add it to the sequence accumulator.                          # Here we have a data line, so we add it to the sequence accumulator.
1444                          # First, we get the actual data out.                          # First, we get the actual data out. Note that we normalize to upper
1445                            # case.
1446                          $line =~ /^\s*(.*?)(\s|\n)/;                          $line =~ /^\s*(.*?)(\s|\n)/;
1447                          $sequence .= $1;                          $sequence .= $1;
1448                  }                  }
1449          }          }
1450          # Flush out the last sequence (if any).          # Flush out the last sequence (if any).
1451          if ($sequence) {          if ($sequence) {
1452                  $retVal {$id} = $sequence;                  $retVal{$id} = uc $sequence;
1453          }          }
1454            # Close the file.
1455            close FASTAFILE;
1456          # Return the hash constructed from the file.          # Return the hash constructed from the file.
1457          return %retVal;          return %retVal;
1458  }  }
# Line 1409  Line 1463 
1463    
1464  Insure that a list of feature locations is in the Sprout format. The Sprout feature location  Insure that a list of feature locations is in the Sprout format. The Sprout feature location
1465  format is I<contig>_I<beg*len> where I<*> is C<+> for a forward gene and C<-> for a backward  format is I<contig>_I<beg*len> where I<*> is C<+> for a forward gene and C<-> for a backward
1466  gene. The old format is I<contig>_I<beg>_I<end>.  gene. The old format is I<contig>_I<beg>_I<end>. If a feature is in the new format already,
1467    it will not be changed; otherwise, it will be converted. This method can also be used to
1468    perform the reverse task-- insuring that all the locations are in the old format.
1469    
1470  =over 4  =over 4
1471    
# Line 1436  Line 1492 
1492  #: Return Type @;  #: Return Type @;
1493  sub FormatLocations {  sub FormatLocations {
1494          # Get the parameters.          # Get the parameters.
1495          my $self = shift @_;          my ($self, $prefix, $locations, $oldFormat) = @_;
         my ($prefix, $locations, $oldFormat) = @_;  
1496          # Create the return list.          # Create the return list.
1497          my @retVal = ();          my @retVal = ();
1498          # Check to see if any locations were passed in.          # Check to see if any locations were passed in.
1499          if ($locations eq '') {          if ($locations eq '') {
1500              confess "No locations specified.";              Confess("No locations specified.");
1501          } else {          } else {
1502                  # Loop through the locations, converting them to the new format.                  # Loop through the locations, converting them to the new format.
1503                  for my $location (@{$locations}) {                  for my $location (@{$locations}) {
# Line 1477  Line 1532 
1532    
1533  sub DumpData {  sub DumpData {
1534          # Get the parameters.          # Get the parameters.
1535          my $self = shift @_;          my ($self) = @_;
1536          # Get the data directory name.          # Get the data directory name.
1537          my $outputDirectory = $self->{_options}->{dataDir};          my $outputDirectory = $self->{_options}->{dataDir};
1538          # Dump the relations.          # Dump the relations.
# Line 1493  Line 1548 
1548  =cut  =cut
1549  #: Return Type $;  #: Return Type $;
1550  sub XMLFileName {  sub XMLFileName {
1551          my $self = shift @_;          my ($self) = @_;
1552          return $self->{_xmlName};          return $self->{_xmlName};
1553  }  }
1554    
# Line 1531  Line 1586 
1586  #: Return Type ;  #: Return Type ;
1587  sub Insert {  sub Insert {
1588          # Get the parameters.          # Get the parameters.
1589          my $self = shift @_;          my ($self, $objectType, $fieldHash) = @_;
         my ($objectType, $fieldHash) = @_;  
1590          # Call the underlying method.          # Call the underlying method.
1591          $self->{_erdb}->InsertObject($objectType, $fieldHash);          $self->{_erdb}->InsertObject($objectType, $fieldHash);
1592  }  }
# Line 1573  Line 1627 
1627  #: Return Type $;  #: Return Type $;
1628  sub Annotate {  sub Annotate {
1629          # Get the parameters.          # Get the parameters.
1630          my $self = shift @_;          my ($self, $fid, $timestamp, $user, $text) = @_;
         my ($fid, $timestamp, $user, $text) = @_;  
1631          # Create the annotation ID.          # Create the annotation ID.
1632          my $aid = "$fid:$timestamp";          my $aid = "$fid:$timestamp";
1633          # Insert the Annotation object.          # Insert the Annotation object.
# Line 1594  Line 1647 
1647    
1648  =head3 AssignFunction  =head3 AssignFunction
1649    
1650  C<< my $ok = $sprout->AssignFunction($featureID, $user, $function); >>  C<< my $ok = $sprout->AssignFunction($featureID, $user, $function, $assigningUser); >>
1651    
1652  This method assigns a function to a feature. Functions are a special type of annotation. The general  This method assigns a function to a feature. Functions are a special type of annotation. The general
1653  format is "XXXX\nset XXXX function to\nYYYYY" where XXXX is the feature type and YYYY is the functional  format is described in L</ParseAssignment>.
 assignment text.  
1654    
1655  =over 4  =over 4
1656    
# Line 1608  Line 1660 
1660    
1661  =item user  =item user
1662    
1663  Name of the user making the assignment. This is frequently a group name, like C<kegg> or C<fig>.  Name of the user group making the assignment, such as C<kegg> or C<fig>.
1664    
1665  =item function  =item function
1666    
1667  Text of the function being assigned.  Text of the function being assigned.
1668    
1669    =item assigningUser (optional)
1670    
1671    Name of the individual user making the assignment. If omitted, defaults to the user group.
1672    
1673  =item RETURN  =item RETURN
1674    
1675  Returns 1 if successful, 0 if an error occurred.  Returns 1 if successful, 0 if an error occurred.
# Line 1624  Line 1680 
1680  #: Return Type $;  #: Return Type $;
1681  sub AssignFunction {  sub AssignFunction {
1682          # Get the parameters.          # Get the parameters.
1683          my $self = shift @_;          my ($self, $featureID, $user, $function, $assigningUser) = @_;
1684          my ($featureID, $user, $function) = @_;      # Default the assigning user.
1685        if (! $assigningUser) {
1686            $assigningUser = $user;
1687        }
1688          # Create an annotation string from the parameters.          # Create an annotation string from the parameters.
1689          my $annotationText = "$user\nset $user function to\n$function";          my $annotationText = "$assigningUser\nset $user function to\n$function";
1690          # Get the current time.          # Get the current time.
1691          my $now = time;          my $now = time;
1692          # Declare the return variable.          # Declare the return variable.
# Line 1672  Line 1731 
1731  #: Return Type @;  #: Return Type @;
1732  sub FeaturesByAlias {  sub FeaturesByAlias {
1733          # Get the parameters.          # Get the parameters.
1734          my $self = shift @_;          my ($self, $alias) = @_;
         my ($alias) = @_;  
1735          # Declare the return variable.          # Declare the return variable.
1736          my @retVal = ();          my @retVal = ();
1737          # Parse the alias.          # Parse the alias.
# Line 1715  Line 1773 
1773  #: Return Type $;  #: Return Type $;
1774  sub Exists {  sub Exists {
1775          # Get the parameters.          # Get the parameters.
1776          my $self = shift @_;          my ($self, $entityName, $entityID) = @_;
         my ($entityName, $entityID) = @_;  
1777          # Check for the entity instance.          # Check for the entity instance.
1778          my $testInstance = $self->GetEntity($entityName, $entityID);          my $testInstance = $self->GetEntity($entityName, $entityID);
1779          # Return an existence indicator.          # Return an existence indicator.
# Line 1746  Line 1803 
1803  #: Return Type $;  #: Return Type $;
1804  sub FeatureTranslation {  sub FeatureTranslation {
1805          # Get the parameters.          # Get the parameters.
1806          my $self = shift @_;          my ($self, $featureID) = @_;
         my ($featureID) = @_;  
1807          # Get the specified feature's translation.          # Get the specified feature's translation.
1808          my ($retVal) = $self->GetEntityValues("Feature", $featureID, ['Feature(translation)']);          my ($retVal) = $self->GetEntityValues("Feature", $featureID, ['Feature(translation)']);
1809          return $retVal;          return $retVal;
# Line 1779  Line 1835 
1835  #: Return Type @;  #: Return Type @;
1836  sub Taxonomy {  sub Taxonomy {
1837          # Get the parameters.          # Get the parameters.
1838          my $self = shift @_;          my ($self, $genome) = @_;
         my ($genome) = @_;  
1839          # Find the specified genome's taxonomy string.          # Find the specified genome's taxonomy string.
1840          my ($list) = $self->GetEntityValues('Genome', $genome, ['Genome(taxonomy)']);          my ($list) = $self->GetEntityValues('Genome', $genome, ['Genome(taxonomy)']);
1841          # Declare the return variable.          # Declare the return variable.
# Line 1823  Line 1878 
1878  #: Return Type $;  #: Return Type $;
1879  sub CrudeDistance {  sub CrudeDistance {
1880          # Get the parameters.          # Get the parameters.
1881          my $self = shift @_;          my ($self, $genome1, $genome2) = @_;
         my ($genome1, $genome2) = @_;  
1882          # Insure that the distance is commutative by sorting the genome IDs.          # Insure that the distance is commutative by sorting the genome IDs.
1883          my ($genomeA, $genomeB);          my ($genomeA, $genomeB);
1884          if ($genome2 < $genome2) {          if ($genome2 < $genome2) {
# Line 1871  Line 1925 
1925  #: Return Type $;  #: Return Type $;
1926  sub RoleName {  sub RoleName {
1927          # Get the parameters.          # Get the parameters.
1928          my $self = shift @_;          my ($self, $roleID) = @_;
         my ($roleID) = @_;  
1929          # Get the specified role's name.          # Get the specified role's name.
1930          my ($retVal) = $self->GetEntityValues('Role', $roleID, ['Role(name)']);          my ($retVal) = $self->GetEntityValues('Role', $roleID, ['Role(name)']);
1931          # Use the ID if the role has no name.          # Use the ID if the role has no name.
# Line 1905  Line 1958 
1958  #: Return Type @;  #: Return Type @;
1959  sub RoleDiagrams {  sub RoleDiagrams {
1960          # Get the parameters.          # Get the parameters.
1961          my $self = shift @_;          my ($self, $roleID) = @_;
         my ($roleID) = @_;  
1962          # Query for the diagrams.          # Query for the diagrams.
1963          my @retVal = $self->GetFlat(['RoleOccursIn'], "RoleOccursIn(from-link) = ?", [$roleID],          my @retVal = $self->GetFlat(['RoleOccursIn'], "RoleOccursIn(from-link) = ?", [$roleID],
1964                                                                  'RoleOccursIn(to-link)');                                                                  'RoleOccursIn(to-link)');
# Line 1943  Line 1995 
1995  #: Return Type @@;  #: Return Type @@;
1996  sub FeatureProperties {  sub FeatureProperties {
1997          # Get the parameters.          # Get the parameters.
1998          my $self = shift @_;          my ($self, $featureID) = @_;
         my ($featureID) = @_;  
1999          # Get the properties.          # Get the properties.
2000          my @retVal = $self->GetAll(['HasProperty', 'Property'], "HasProperty(from-link) = ?", [$featureID],          my @retVal = $self->GetAll(['HasProperty', 'Property'], "HasProperty(from-link) = ?", [$featureID],
2001                                                          ['Property(property-name)', 'Property(property-value)',                                                          ['Property(property-name)', 'Property(property-value)',
# Line 1975  Line 2026 
2026  #: Return Type $;  #: Return Type $;
2027  sub DiagramName {  sub DiagramName {
2028          # Get the parameters.          # Get the parameters.
2029          my $self = shift @_;          my ($self, $diagramID) = @_;
         my ($diagramID) = @_;  
2030          # Get the specified diagram's name and return it.          # Get the specified diagram's name and return it.
2031          my ($retVal) = $self->GetEntityValues('Diagram', $diagramID, ['Diagram(name)']);          my ($retVal) = $self->GetEntityValues('Diagram', $diagramID, ['Diagram(name)']);
2032          return $retVal;          return $retVal;
# Line 2008  Line 2058 
2058  #: Return Type @;  #: Return Type @;
2059  sub MergedAnnotations {  sub MergedAnnotations {
2060          # Get the parameters.          # Get the parameters.
2061          my $self = shift @_;          my ($self, $list) = @_;
         my ($list) = @_;  
2062          # Create a list to hold the annotation tuples found.          # Create a list to hold the annotation tuples found.
2063          my @tuples = ();          my @tuples = ();
2064          # Loop through the features in the input list.          # Loop through the features in the input list.
# Line 2057  Line 2106 
2106  #: Return Type @;  #: Return Type @;
2107  sub RoleNeighbors {  sub RoleNeighbors {
2108          # Get the parameters.          # Get the parameters.
2109          my $self = shift @_;          my ($self, $roleID) = @_;
         my ($roleID) = @_;  
2110          # Get all the diagrams containing this role.          # Get all the diagrams containing this role.
2111          my @diagrams = $self->GetFlat(['RoleOccursIn'], "RoleOccursIn(from-link) = ?", [$roleID],          my @diagrams = $self->GetFlat(['RoleOccursIn'], "RoleOccursIn(from-link) = ?", [$roleID],
2112                                                                    'RoleOccursIn(to-link)');                                                                    'RoleOccursIn(to-link)');
# Line 2100  Line 2148 
2148  #: Return Type @;  #: Return Type @;
2149  sub FeatureLinks {  sub FeatureLinks {
2150          # Get the parameters.          # Get the parameters.
2151          my $self = shift @_;          my ($self, $featureID) = @_;
         my ($featureID) = @_;  
2152          # Get the feature's links.          # Get the feature's links.
2153          my @retVal = $self->GetEntityValues('Feature', $featureID, ['Feature(link)']);          my @retVal = $self->GetEntityValues('Feature', $featureID, ['Feature(link)']);
2154          # Return the feature's links.          # Return the feature's links.
# Line 2131  Line 2178 
2178  #: Return Type %;  #: Return Type %;
2179  sub SubsystemsOf {  sub SubsystemsOf {
2180          # Get the parameters.          # Get the parameters.
2181          my $self = shift @_;          my ($self, $featureID) = @_;
         my ($featureID) = @_;  
2182          # Use the SSCell to connect features to subsystems.          # Use the SSCell to connect features to subsystems.
2183          my @subsystems = $self->GetAll(['ContainsFeature', 'HasSSCell', 'IsRoleOf'],          my @subsystems = $self->GetAll(['ContainsFeature', 'HasSSCell', 'IsRoleOf'],
2184                                                                          "ContainsFeature(to-link) = ?", [$featureID],                                                                          "ContainsFeature(to-link) = ?", [$featureID],
# Line 2180  Line 2226 
2226  #: Return Type @;  #: Return Type @;
2227  sub RelatedFeatures {  sub RelatedFeatures {
2228          # Get the parameters.          # Get the parameters.
2229          my $self = shift @_;          my ($self, $featureID, $function, $userID) = @_;
         my ($featureID, $function, $userID) = @_;  
2230          # Get a list of the features that are BBHs of the incoming feature.          # Get a list of the features that are BBHs of the incoming feature.
2231          my @bbhFeatures = $self->GetFlat(['IsBidirectionalBestHitOf'],          my @bbhFeatures = $self->GetFlat(['IsBidirectionalBestHitOf'],
2232                                                                           "IsBidirectionalBestHitOf(from-link) = ?", [$featureID],                                                                           "IsBidirectionalBestHitOf(from-link) = ?", [$featureID],
# Line 2229  Line 2274 
2274  #: Return Type @;  #: Return Type @;
2275  sub TaxonomySort {  sub TaxonomySort {
2276          # Get the parameters.          # Get the parameters.
2277          my $self = shift @_;          my ($self, $featureIDs) = @_;
         my ($featureIDs) = @_;  
2278          # Create the working hash table.          # Create the working hash table.
2279          my %hashBuffer = ();          my %hashBuffer = ();
2280          # Loop through the features.          # Loop through the features.
# Line 2239  Line 2283 
2283                  my ($taxonomy) = $self->GetFlat(['IsLocatedIn', 'HasContig', 'Genome'], "IsLocatedIn(from-link) = ?",                  my ($taxonomy) = $self->GetFlat(['IsLocatedIn', 'HasContig', 'Genome'], "IsLocatedIn(from-link) = ?",
2284                                                                                  [$fid], 'Genome(taxonomy)');                                                                                  [$fid], 'Genome(taxonomy)');
2285                  # Add this feature to the hash buffer.                  # Add this feature to the hash buffer.
2286                  if (exists $hashBuffer{$taxonomy}) {          Tracer::AddToListMap(\%hashBuffer, $taxonomy, $fid);
                         push @{$hashBuffer{$taxonomy}}, $fid;  
                 } else {  
                         $hashBuffer{$taxonomy} = [$fid];  
                 }  
2287          }          }
2288          # Sort the keys and get the elements.          # Sort the keys and get the elements.
2289          my @retVal = ();          my @retVal = ();
# Line 2312  Line 2352 
2352  #: Return Type @@;  #: Return Type @@;
2353  sub GetAll {  sub GetAll {
2354          # Get the parameters.          # Get the parameters.
2355          my $self = shift @_;          my ($self, $objectNames, $filterClause, $parameterList, $fields, $count) = @_;
         my ($objectNames, $filterClause, $parameterList, $fields, $count) = @_;  
2356          # Create the query.          # Create the query.
2357          my $query = $self->Get($objectNames, $filterClause, $parameterList);          my $query = $self->Get($objectNames, $filterClause, $parameterList);
2358          # Set up a counter of the number of records read.          # Set up a counter of the number of records read.
# Line 2374  Line 2413 
2413  #: Return Type @;  #: Return Type @;
2414  sub GetFlat {  sub GetFlat {
2415          # Get the parameters.          # Get the parameters.
2416          my $self = shift @_;          my ($self, $objectNames, $filterClause, $parameterList, $field) = @_;
         my ($objectNames, $filterClause, $parameterList, $field) = @_;  
2417          # Construct the query.          # Construct the query.
2418          my $query = $self->Get($objectNames, $filterClause, $parameterList);          my $query = $self->Get($objectNames, $filterClause, $parameterList);
2419          # Create the result list.          # Create the result list.
# Line 2485  Line 2523 
2523  #: Return Type @;  #: Return Type @;
2524  sub LoadInfo {  sub LoadInfo {
2525          # Get the parameters.          # Get the parameters.
2526          my $self = shift @_;          my ($self) = @_;
2527          # Create the return list, priming it with the name of the data directory.          # Create the return list, priming it with the name of the data directory.
2528          my @retVal = ($self->{_options}->{dataDir});          my @retVal = ($self->{_options}->{dataDir});
2529          # Concatenate the table names.          # Concatenate the table names.
# Line 2522  Line 2560 
2560  #: Return Type %;  #: Return Type %;
2561  sub LowBBHs {  sub LowBBHs {
2562          # Get the parsameters.          # Get the parsameters.
2563          my $self = shift @_;          my ($self, $featureID, $cutoff) = @_;
         my ($featureID, $cutoff) = @_;  
2564          # Create the return hash.          # Create the return hash.
2565          my %retVal = ();          my %retVal = ();
2566          # Create a query to get the desired BBHs.          # Create a query to get the desired BBHs.
# Line 2539  Line 2576 
2576          return %retVal;          return %retVal;
2577  }  }
2578    
2579    =head3 GetGroups
2580    
2581    C<< my %groups = $sprout->GetGroups(\@groupList); >>
2582    
2583    Return a hash mapping each group to the IDs of the genomes in the group.
2584    A list of groups may be specified, in which case only those groups will be
2585    shown. Alternatively, if no parameter is supplied, all groups will be
2586    included. Genomes that are not in any group are omitted.
2587    
2588    =cut
2589    #: Return Type %@;
2590    sub GetGroups {
2591        # Get the parameters.
2592        my ($self, $groupList) = @_;
2593        # Declare the return value.
2594        my %retVal = ();
2595        # Determine whether we are getting all the groups or just some.
2596        if (defined $groupList) {
2597            # Here we have a group list. Loop through them individually,
2598            # getting a list of the relevant genomes.
2599            for my $group (@{$groupList}) {
2600                my @genomeIDs = $self->GetFlat(['Genome'], "Genome(group-name) = ?",
2601                    [$group], "Genome(id)");
2602                $retVal{$group} = \@genomeIDs;
2603            }
2604        } else {
2605            # Here we need all of the groups. In this case, we run through all
2606            # of the genome records, putting each one found into the appropriate
2607            # group. Note that we use a filter clause to insure that only genomes
2608            # in groups are included in the return set.
2609            my @genomes = $self->GetAll(['Genome'], "Genome(group-name) > ' '", [],
2610                                        ['Genome(id)', 'Genome(group-name)']);
2611            # Loop through the genomes found.
2612            for my $genome (@genomes) {
2613                # Pop this genome's ID off the current list.
2614                my @groups = @{$genome};
2615                my $genomeID = shift @groups;
2616                # Loop through the groups, adding the genome ID to each group's
2617                # list.
2618                for my $group (@groups) {
2619                    Tracer::AddToListMap(\%retVal, $group, $genomeID);
2620                }
2621            }
2622        }
2623        # Return the hash we just built.
2624        return %retVal;
2625    }
2626    
2627  =head2 Internal Utility Methods  =head2 Internal Utility Methods
2628    
2629  =head3 ParseAssignment  =head3 ParseAssignment
2630    
2631  Parse annotation text to determine whether or not it is a functional assignment. If it is,  Parse annotation text to determine whether or not it is a functional assignment. If it is,
2632  the user and function text will be returned as a 2-element list. If it isn't, an empty list  the user, function text, and assigning user will be returned as a 3-element list. If it
2633  will be returned.  isn't, an empty list will be returned.
2634    
2635    A functional assignment is always of the form
2636    
2637        I<XXXX>C<\nset >I<YYYY>C< function to\n>I<ZZZZZ>
2638    
2639    where I<XXXX> is the B<assigning user>, I<YYYY> is the B<user>, and I<ZZZZ> is the
2640    actual functional role. In most cases, the user and the assigning user will be the
2641    same, but that is not always the case.
2642    
2643  This is a static method.  This is a static method.
2644    
# Line 2564  Line 2657 
2657    
2658  =cut  =cut
2659    
2660  sub ParseAssignment {  sub _ParseAssignment {
2661          # Get the parameters.          # Get the parameters.
2662          my ($text) = @_;          my ($text) = @_;
2663          # Declare the return value.          # Declare the return value.
2664          my @retVal = ();          my @retVal = ();
2665          # Check to see if this is a functional assignment.          # Check to see if this is a functional assignment.
2666          my ($user, $type, $function) = split(/\n/, $text);          my ($user, $type, $function) = split(/\n/, $text);
2667          if ($type =~ m/^set $user function to$/i) {          if ($type =~ m/^set ([^ ]+) function to$/i) {
2668                  # Here it is, so we return the user name and function text.                  # Here it is, so we return the user name (which is in $1), the functional role text,
2669                  @retVal = ($user, $function);          # and the assigning user.
2670                    @retVal = ($1, $function, $user);
2671          }          }
2672          # Return the result list.          # Return the result list.
2673          return @retVal;          return @retVal;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3