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

Diff of /Sprout/ERDB.pm

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

revision 1.30, Wed Jan 11 19:39:03 2006 UTC revision 1.42, Wed Apr 19 03:34:15 2006 UTC
# Line 9  Line 9 
9      use DBObject;      use DBObject;
10      use Stats;      use Stats;
11      use Time::HiRes qw(gettimeofday);      use Time::HiRes qw(gettimeofday);
12        use Digest::MD5 qw(md5_base64);
13      use FIG;      use FIG;
14    
15  =head1 Entity-Relationship Database Package  =head1 Entity-Relationship Database Package
# Line 125  Line 126 
126    
127  variable-length string, maximum 255 characters  variable-length string, maximum 255 characters
128    
129    =item hash-string
130    
131    variable-length string, maximum 22 characters
132    
133  =back  =back
134    
135    The hash-string data type has a special meaning. The actual key passed into the loader will
136    be a string, but it will be digested into a 22-character MD5 code to save space. Although the
137    MD5 algorithm is not perfect, it is extremely unlikely two strings will have the same
138    digest. Therefore, it is presumed the keys will be unique. When the database is actually
139    in use, the hashed keys will be presented rather than the original values. For this reason,
140    they should not be used for entities where the key is meaningful.
141    
142  =head3 Global Tags  =head3 Global Tags
143    
144  The entire database definition must be inside a B<Database> tag. The display name of  The entire database definition must be inside a B<Database> tag. The display name of
# Line 309  Line 321 
321                    text =>    { sqlType => 'TEXT',               maxLen => 1000000000,   avgLen => 500, dataGen => "StringGen(IntGen(80,1000))" },                    text =>    { sqlType => 'TEXT',               maxLen => 1000000000,   avgLen => 500, dataGen => "StringGen(IntGen(80,1000))" },
322                    date =>    { sqlType => 'BIGINT',             maxLen => 80,           avgLen =>   8, dataGen => "DateGen(-7, 7, IntGen(0,1400))" },                    date =>    { sqlType => 'BIGINT',             maxLen => 80,           avgLen =>   8, dataGen => "DateGen(-7, 7, IntGen(0,1400))" },
323                    float =>   { sqlType => 'DOUBLE PRECISION',   maxLen => 40,           avgLen =>   8, dataGen => "FloatGen(0.0, 100.0)" },                    float =>   { sqlType => 'DOUBLE PRECISION',   maxLen => 40,           avgLen =>   8, dataGen => "FloatGen(0.0, 100.0)" },
324                    boolean => { sqlType => 'SMALLINT',           maxLen => 1,            avgLen =>   2, dataGen => "IntGen(0, 1)" },                    boolean => { sqlType => 'SMALLINT',           maxLen => 1,            avgLen =>   1, dataGen => "IntGen(0, 1)" },
325                     'hash-string' =>
326                                 { sqlType => 'VARCHAR(22)',        maxLen => 22,           avgLen =>  22, dataGen => "SringGen(22)" },
327                   'key-string' =>                   'key-string' =>
328                               { sqlType => 'VARCHAR(40)',        maxLen => 40,           avgLen =>  10, dataGen => "StringGen(IntGen(10,40))" },                               { sqlType => 'VARCHAR(40)',        maxLen => 40,           avgLen =>  10, dataGen => "StringGen(IntGen(10,40))" },
329                   'name-string' =>                   'name-string' =>
# Line 632  Line 646 
646      }      }
647  }  }
648    
649    =head3 VerifyFields
650    
651    C<< my $count = $erdb->VerifyFields($relName, \@fieldList); >>
652    
653    Run through the list of proposed field values, insuring that all the character fields are
654    below the maximum length. If any fields are too long, they will be truncated in place.
655    
656    =over 4
657    
658    =item relName
659    
660    Name of the relation for which the specified fields are destined.
661    
662    =item fieldList
663    
664    Reference to a list, in order, of the fields to be put into the relation.
665    
666    =item RETURN
667    
668    Returns the number of fields truncated.
669    
670    =back
671    
672    =cut
673    
674    sub VerifyFields {
675        # Get the parameters.
676        my ($self, $relName, $fieldList) = @_;
677        # Initialize the return value.
678        my $retVal = 0;
679        # Get the relation definition.
680        my $relData = $self->_FindRelation($relName);
681        # Get the list of field descriptors.
682        my $fieldTypes = $relData->{Fields};
683        my $fieldCount = scalar @{$fieldTypes};
684        # Loop through the two lists.
685        for (my $i = 0; $i < $fieldCount; $i++) {
686            # Get the type of the current field.
687            my $fieldType = $fieldTypes->[$i]->{type};
688            # If it's a character field, verify the length.
689            if ($fieldType =~ /string/) {
690                my $maxLen = $TypeTable{$fieldType}->{maxLen};
691                my $oldString = $fieldList->[$i];
692                if (length($oldString) > $maxLen) {
693                    # Here it's too big, so we truncate it.
694                    Trace("Truncating field $i in relation $relName to $maxLen characters from \"$oldString\".") if T(1);
695                    $fieldList->[$i] = substr $oldString, 0, $maxLen;
696                    $retVal++;
697                }
698            }
699        }
700        # Return the truncation count.
701        return $retVal;
702    }
703    
704    =head3 DigestFields
705    
706    C<< $erdb->DigestFields($relName, $fieldList); >>
707    
708    Digest the strings in the field list that correspond to data type C<hash-string> in the
709    specified relation.
710    
711    =over 4
712    
713    =item relName
714    
715    Name of the relation to which the fields belong.
716    
717    =item fieldList
718    
719    List of field contents to be loaded into the relation.
720    
721    =back
722    
723    =cut
724    #: Return Type ;
725    sub DigestFields {
726        # Get the parameters.
727        my ($self, $relName, $fieldList) = @_;
728        # Get the relation definition.
729        my $relData = $self->_FindRelation($relName);
730        # Get the list of field descriptors.
731        my $fieldTypes = $relData->{Fields};
732        my $fieldCount = scalar @{$fieldTypes};
733        # Loop through the two lists.
734        for (my $i = 0; $i < $fieldCount; $i++) {
735            # Get the type of the current field.
736            my $fieldType = $fieldTypes->[$i]->{type};
737            # If it's a hash string, digest it in place.
738            if ($fieldType eq 'hash-string') {
739                $fieldList->[$i] = md5_base64($fieldList->[$i]);
740            }
741        }
742    }
743    
744  =head3 CreateIndex  =head3 CreateIndex
745    
746  C<< $erdb->CreateIndex($relationName); >>  C<< $erdb->CreateIndex($relationName); >>
# Line 822  Line 931 
931    
932  If multiple names are specified, then the query processor will automatically determine a  If multiple names are specified, then the query processor will automatically determine a
933  join path between the entities and relationships. The algorithm used is very simplistic.  join path between the entities and relationships. The algorithm used is very simplistic.
934  In particular, you can't specify any entity or relationship more than once, and if a  In particular, if a relationship is recursive, the path is determined by the order in which
935  relationship is recursive, the path is determined by the order in which the entity  the entity and the relationship appear. For example, consider a recursive relationship
936  and the relationship appear. For example, consider a recursive relationship B<IsParentOf>  B<IsParentOf> which relates B<People> objects to other B<People> objects. If the join path is
 which relates B<People> objects to other B<People> objects. If the join path is  
937  coded as C<['People', 'IsParentOf']>, then the people returned will be parents. If, however,  coded as C<['People', 'IsParentOf']>, then the people returned will be parents. If, however,
938  the join path is C<['IsParentOf', 'People']>, then the people returned will be children.  the join path is C<['IsParentOf', 'People']>, then the people returned will be children.
939    
940    If an entity or relationship is mentioned twice, the name for the second occurrence will
941    be suffixed with C<2>, the third occurrence will be suffixed with C<3>, and so forth. So,
942    for example, if we have C<['Feature', 'HasContig', 'Contig', 'HasContig']>, then the
943    B<to-link> field of the first B<HasContig> is specified as C<HasContig(to-link)>, while
944    the B<to-link> field of the second B<HasContig> is specified as C<HasContig2(to-link)>.
945    
946  =over 4  =over 4
947    
948  =item objectNames  =item objectNames
# Line 858  Line 972 
972  filter clause in general; however, odd things may happen if a sort field is from a secondary  filter clause in general; however, odd things may happen if a sort field is from a secondary
973  relation.  relation.
974    
975    Finally, you can limit the number of rows returned by adding a LIMIT clause. The LIMIT must
976    be the last thing in the filter clause, and it contains only the word "LIMIT" followed by
977    a positive number. So, for example
978    
979    C<< "Genome(genus) = ? ORDER BY Genome(species) LIMIT 10" >>
980    
981    will only return the first ten genomes for the specified genus. The ORDER BY clause is not
982    required. For example, to just get the first 10 genomes in the B<Genome> table, you could
983    use
984    
985    C<< "LIMIT 10" >>
986    
987  =item param1, param2, ..., paramN  =item param1, param2, ..., paramN
988    
989  Parameter values to be substituted into the filter clause.  Parameter values to be substituted into the filter clause.
# Line 873  Line 999 
999  sub Get {  sub Get {
1000      # Get the parameters.      # Get the parameters.
1001      my ($self, $objectNames, $filterClause, @params) = @_;      my ($self, $objectNames, $filterClause, @params) = @_;
1002        # Adjust the list of object names to account for multiple occurrences of the
1003        # same object. We start with a hash table keyed on object name that will
1004        # return the object suffix. The first time an object is encountered it will
1005        # not be found in the hash. The next time the hash will map the object name
1006        # to 2, then 3, and so forth.
1007        my %objectHash = ();
1008        # This list will contain the object names as they are to appear in the
1009        # FROM list.
1010        my @fromList = ();
1011        # This list contains the suffixed object name for each object. It is exactly
1012        # parallel to the list in the $objectNames parameter.
1013        my @mappedNameList = ();
1014        # Finally, this hash translates from a mapped name to its original object name.
1015        my %mappedNameHash = ();
1016        # Now we create the lists. Note that for every single name we push something into
1017        # @fromList and @mappedNameList. This insures that those two arrays are exactly
1018        # parallel to $objectNames.
1019        for my $objectName (@{$objectNames}) {
1020            # Get the next suffix for this object.
1021            my $suffix = $objectHash{$objectName};
1022            if (! $suffix) {
1023                # Here we are seeing the object for the first time. The object name
1024                # is used as is.
1025                push @mappedNameList, $objectName;
1026                push @fromList, $objectName;
1027                $mappedNameHash{$objectName} = $objectName;
1028                # Denote the next suffix will be 2.
1029                $objectHash{$objectName} = 2;
1030            } else {
1031                # Here we've seen the object before. We construct a new name using
1032                # the suffix from the hash and update the hash.
1033                my $mappedName = "$objectName$suffix";
1034                $objectHash{$objectName} = $suffix + 1;
1035                # The FROM list has the object name followed by the mapped name. This
1036                # tells SQL it's still the same table, but we're using a different name
1037                # for it to avoid confusion.
1038                push @fromList, "$objectName $mappedName";
1039                # The mapped-name list contains the real mapped name.
1040                push @mappedNameList, $mappedName;
1041                # Finally, enable us to get back from the mapped name to the object name.
1042                $mappedNameHash{$mappedName} = $objectName;
1043            }
1044        }
1045      # Construct the SELECT statement. The general pattern is      # Construct the SELECT statement. The general pattern is
1046      #      #
1047      # SELECT name1.*, name2.*, ... nameN.* FROM name1, name2, ... nameN      # SELECT name1.*, name2.*, ... nameN.* FROM name1, name2, ... nameN
1048      #      #
1049      my $dbh = $self->{_dbh};      my $dbh = $self->{_dbh};
1050      my $command = "SELECT DISTINCT " . join('.*, ', @{$objectNames}) . ".* FROM " .      my $command = "SELECT DISTINCT " . join('.*, ', @mappedNameList) . ".* FROM " .
1051                  join(', ', @{$objectNames});                  join(', ', @fromList);
1052      # Check for a filter clause.      # Check for a filter clause.
1053      if ($filterClause) {      if ($filterClause) {
1054          # Here we have one, so we convert its field names and add it to the query. First,          # Here we have one, so we convert its field names and add it to the query. First,
# Line 887  Line 1056 
1056          my $filterString = $filterClause;          my $filterString = $filterClause;
1057          # Next, we sort the object names by length. This helps protect us from finding          # Next, we sort the object names by length. This helps protect us from finding
1058          # object names inside other object names when we're doing our search and replace.          # object names inside other object names when we're doing our search and replace.
1059          my @sortedNames = sort { length($b) - length($a) } @{$objectNames};          my @sortedNames = sort { length($b) - length($a) } @mappedNameList;
1060          # We will also keep a list of conditions to add to the WHERE clause in order to link          # We will also keep a list of conditions to add to the WHERE clause in order to link
1061          # entities and relationships as well as primary relations to secondary ones.          # entities and relationships as well as primary relations to secondary ones.
1062          my @joinWhere = ();          my @joinWhere = ();
1063          # The final preparatory step is to create a hash table of relation names. The          # The final preparatory step is to create a hash table of relation names. The
1064          # table begins with the relation names already in the SELECT command.          # table begins with the relation names already in the SELECT command. We may
1065          my %fromNames = ();          # need to add relations later if there is filtering on a field in a secondary
1066          for my $objectName (@sortedNames) {          # relation. The secondary relations are the ones that contain multiply-
1067              $fromNames{$objectName} = 1;          # occurring or optional fields.
1068          }          my %fromNames = map { $_ => 1 } @sortedNames;
1069          # We are ready to begin. We loop through the object names, replacing each          # We are ready to begin. We loop through the object names, replacing each
1070          # object name's field references by the corresponding SQL field reference.          # object name's field references by the corresponding SQL field reference.
1071          # Along the way, if we find a secondary relation, we will need to add it          # Along the way, if we find a secondary relation, we will need to add it
1072          # to the FROM clause.          # to the FROM clause.
1073          for my $objectName (@sortedNames) {          for my $mappedName (@sortedNames) {
1074              # Get the length of the object name plus 2. This is the value we add to the              # Get the length of the object name plus 2. This is the value we add to the
1075              # size of the field name to determine the size of the field reference as a              # size of the field name to determine the size of the field reference as a
1076              # whole.              # whole.
1077              my $nameLength = 2 + length $objectName;              my $nameLength = 2 + length $mappedName;
1078                # Get the real object name for this mapped name.
1079                my $objectName = $mappedNameHash{$mappedName};
1080                Trace("Processing $mappedName for object $objectName.") if T(4);
1081              # Get the object's field list.              # Get the object's field list.
1082              my $fieldList = $self->_GetFieldTable($objectName);              my $fieldList = $self->GetFieldTable($objectName);
1083              # Find the field references for this object.              # Find the field references for this object.
1084              while ($filterString =~ m/$objectName\(([^)]*)\)/g) {              while ($filterString =~ m/$mappedName\(([^)]*)\)/g) {
1085                  # At this point, $1 contains the field name, and the current position                  # At this point, $1 contains the field name, and the current position
1086                  # is set immediately after the final parenthesis. We pull out the name of                  # is set immediately after the final parenthesis. We pull out the name of
1087                  # the field and the position and length of the field reference as a whole.                  # the field and the position and length of the field reference as a whole.
# Line 920  Line 1092 
1092                  if (!exists $fieldList->{$fieldName}) {                  if (!exists $fieldList->{$fieldName}) {
1093                      Confess("Field $fieldName not found for object $objectName.");                      Confess("Field $fieldName not found for object $objectName.");
1094                  } else {                  } else {
1095                        Trace("Processing $fieldName at position $pos.") if T(4);
1096                      # Get the field's relation.                      # Get the field's relation.
1097                      my $relationName = $fieldList->{$fieldName}->{relation};                      my $relationName = $fieldList->{$fieldName}->{relation};
1098                        # Now we have a secondary relation. We need to insure it matches the
1099                        # mapped name of the primary relation. First we peel off the suffix
1100                        # from the mapped name.
1101                        my $mappingSuffix = substr $mappedName, length($objectName);
1102                        # Put the mapping suffix onto the relation name to get the
1103                        # mapped relation name.
1104                        my $mappedRelationName = "$relationName$mappingSuffix";
1105                      # Insure the relation is in the FROM clause.                      # Insure the relation is in the FROM clause.
1106                      if (!exists $fromNames{$relationName}) {                      if (!exists $fromNames{$mappedRelationName}) {
1107                          # Add the relation to the FROM clause.                          # Add the relation to the FROM clause.
1108                            if ($mappedRelationName eq $relationName) {
1109                                # The name is un-mapped, so we add it without
1110                                # any frills.
1111                          $command .= ", $relationName";                          $command .= ", $relationName";
                         # Create its join sub-clause.  
1112                          push @joinWhere, "$objectName.id = $relationName.id";                          push @joinWhere, "$objectName.id = $relationName.id";
1113                          # Denote we have it available for future fields.                          } else {
1114                          $fromNames{$relationName} = 1;                              # Here we have a mapping situation.
1115                                $command .= ", $relationName $mappedRelationName";
1116                                push @joinWhere, "$mappedRelationName.id = $mappedName.id";
1117                            }
1118                            # Denote we have this relation available for future fields.
1119                            $fromNames{$mappedRelationName} = 1;
1120                      }                      }
1121                      # Form an SQL field reference from the relation name and the field name.                      # Form an SQL field reference from the relation name and the field name.
1122                      my $sqlReference = "$relationName." . _FixName($fieldName);                      my $sqlReference = "$mappedRelationName." . _FixName($fieldName);
1123                      # Put it into the filter string in place of the old value.                      # Put it into the filter string in place of the old value.
1124                      substr($filterString, $pos, $len) = $sqlReference;                      substr($filterString, $pos, $len) = $sqlReference;
1125                      # Reposition the search.                      # Reposition the search.
# Line 944  Line 1131 
1131          # is more than one object in the object list. We start with the first object and          # is more than one object in the object list. We start with the first object and
1132          # run through the objects after it. Note also that we make a safety copy of the          # run through the objects after it. Note also that we make a safety copy of the
1133          # list before running through it.          # list before running through it.
1134          my @objectList = @{$objectNames};          my @mappedObjectList = @mappedNameList;
1135          my $lastObject = shift @objectList;          my $lastMappedObject = shift @mappedObjectList;
1136          # Get the join table.          # Get the join table.
1137          my $joinTable = $self->{_metaData}->{Joins};          my $joinTable = $self->{_metaData}->{Joins};
1138          # Loop through the object list.          # Loop through the object list.
1139          for my $thisObject (@objectList) {          for my $thisMappedObject (@mappedObjectList) {
1140              # Look for a join.              # Look for a join using the real object names.
1141                my $lastObject = $mappedNameHash{$lastMappedObject};
1142                my $thisObject = $mappedNameHash{$thisMappedObject};
1143              my $joinKey = "$lastObject/$thisObject";              my $joinKey = "$lastObject/$thisObject";
1144              if (!exists $joinTable->{$joinKey}) {              if (!exists $joinTable->{$joinKey}) {
1145                  # Here there's no join, so we throw an error.                  # Here there's no join, so we throw an error.
1146                  Confess("No join exists to connect from $lastObject to $thisObject.");                  Confess("No join exists to connect from $lastMappedObject to $thisMappedObject.");
1147              } else {              } else {
1148                  # Get the join clause and add it to the WHERE list.                  # Get the join clause.
1149                  push @joinWhere, $joinTable->{$joinKey};                  my $unMappedJoin = $joinTable->{$joinKey};
1150                    # Fix the names.
1151                    $unMappedJoin =~ s/$lastObject/$lastMappedObject/;
1152                    $unMappedJoin =~ s/$thisObject/$thisMappedObject/;
1153                    push @joinWhere, $unMappedJoin;
1154                  # Save this object as the last object for the next iteration.                  # Save this object as the last object for the next iteration.
1155                  $lastObject = $thisObject;                  $lastMappedObject = $thisMappedObject;
1156              }              }
1157          }          }
1158          # Now we need to handle the whole ORDER BY / LIMIT thing. The important part          # Now we need to handle the whole ORDER BY / LIMIT thing. The important part
# Line 976  Line 1169 
1169          }          }
1170          # Add the filter and the join clauses (if any) to the SELECT command.          # Add the filter and the join clauses (if any) to the SELECT command.
1171          if ($filterString) {          if ($filterString) {
1172                Trace("Filter string is \"$filterString\".") if T(4);
1173              push @joinWhere, "($filterString)";              push @joinWhere, "($filterString)";
1174          }          }
1175          if (@joinWhere) {          if (@joinWhere) {
# Line 986  Line 1180 
1180              $command .= " $orderClause";              $command .= " $orderClause";
1181          }          }
1182      }      }
1183      Trace("SQL query: $command") if T(SQL => 4);      Trace("SQL query: $command") if T(SQL => 3);
1184      Trace("PARMS: '" . (join "', '", @params) . "'") if (T(SQL => 4) && (@params > 0));      Trace("PARMS: '" . (join "', '", @params) . "'") if (T(SQL => 4) && (@params > 0));
1185      my $sth = $dbh->prepare_command($command);      my $sth = $dbh->prepare_command($command);
1186      # Execute it with the parameters bound in.      # Execute it with the parameters bound in.
1187      $sth->execute(@params) || Confess("SELECT error" . $sth->errstr());      $sth->execute(@params) || Confess("SELECT error" . $sth->errstr());
1188        # Now we create the relation map, which enables DBQuery to determine the order, name
1189        # and mapped name for each object in the query.
1190        my @relationMap = ();
1191        for my $mappedName (@mappedNameList) {
1192            push @relationMap, [$mappedName, $mappedNameHash{$mappedName}];
1193        }
1194      # Return the statement object.      # Return the statement object.
1195      my $retVal = DBQuery::_new($self, $sth, @{$objectNames});      my $retVal = DBQuery::_new($self, $sth, \@relationMap);
1196        return $retVal;
1197    }
1198    
1199    =head3 Delete
1200    
1201    C<< my $stats = $erdb->Delete($entityName, $objectID); >>
1202    
1203    Delete an entity instance from the database. The instance is deleted along with all entity and
1204    relationship instances dependent on it. The idea of dependence here is recursive. An object is
1205    always dependent on itself. An object is dependent if it is a 1-to-many or many-to-many
1206    relationship connected to a dependent entity or the "to" entity connected to a 1-to-many
1207    dependent relationship.
1208    
1209    =over 4
1210    
1211    =item entityName
1212    
1213    Name of the entity type for the instance being deleted.
1214    
1215    =item objectID
1216    
1217    ID of the entity instance to be deleted. If the ID contains a wild card character (C<%>),
1218    then it is presumed to by a LIKE pattern.
1219    
1220    =item testFlag
1221    
1222    If TRUE, the delete statements will be traced without being executed.
1223    
1224    =item RETURN
1225    
1226    Returns a statistics object indicating how many records of each particular table were
1227    deleted.
1228    
1229    =back
1230    
1231    =cut
1232    #: Return Type $%;
1233    sub Delete {
1234        # Get the parameters.
1235        my ($self, $entityName, $objectID, $testFlag) = @_;
1236        # Declare the return variable.
1237        my $retVal = Stats->new();
1238        # Get the DBKernel object.
1239        my $db = $self->{_dbh};
1240        # We're going to generate all the paths branching out from the starting entity. One of
1241        # the things we have to be careful about is preventing loops. We'll use a hash to
1242        # determine if we've hit a loop.
1243        my %alreadyFound = ();
1244        # These next lists will serve as our result stack. We start by pushing object lists onto
1245        # the stack, and then popping them off to do the deletes. This means the deletes will
1246        # start with the longer paths before getting to the shorter ones. That, in turn, makes
1247        # sure we don't delete records that might be needed to forge relationships back to the
1248        # original item. We have two lists-- one for TO-relationships, and one for
1249        # FROM-relationships and entities.
1250        my @fromPathList = ();
1251        my @toPathList = ();
1252        # This final hash is used to remember what work still needs to be done. We push paths
1253        # onto the list, then pop them off to extend the paths. We prime it with the starting
1254        # point. Note that we will work hard to insure that the last item on a path in the
1255        # TODO list is always an entity.
1256        my @todoList = ([$entityName]);
1257        while (@todoList) {
1258            # Get the current path.
1259            my $current = pop @todoList;
1260            # Copy it into a list.
1261            my @stackedPath = @{$current};
1262            # Pull off the last item on the path. It will always be an entity.
1263            my $entityName = pop @stackedPath;
1264            # Add it to the alreadyFound list.
1265            $alreadyFound{$entityName} = 1;
1266            # Get the entity data.
1267            my $entityData = $self->_GetStructure($entityName);
1268            # The first task is to loop through the entity's relation. A DELETE command will
1269            # be needed for each of them.
1270            my $relations = $entityData->{Relations};
1271            for my $relation (keys %{$relations}) {
1272                my @augmentedList = (@stackedPath, $relation);
1273                push @fromPathList, \@augmentedList;
1274            }
1275            # Now we need to look for relationships connected to this entity.
1276            my $relationshipList = $self->{_metaData}->{Relationships};
1277            for my $relationshipName (keys %{$relationshipList}) {
1278                my $relationship = $relationshipList->{$relationshipName};
1279                # Check the FROM field. We're only interested if it's us.
1280                if ($relationship->{from} eq $entityName) {
1281                    # Add the path to this relationship.
1282                    my @augmentedList = (@stackedPath, $entityName, $relationshipName);
1283                    push @fromPathList, \@augmentedList;
1284                    # Check the arity. If it's MM we're done. If it's 1M
1285                    # and the target hasn't been seen yet, we want to
1286                    # stack the entity for future processing.
1287                    if ($relationship->{arity} eq '1M') {
1288                        my $toEntity = $relationship->{to};
1289                        if (! exists $alreadyFound{$toEntity}) {
1290                            # Here we have a new entity that's dependent on
1291                            # the current entity, so we need to stack it.
1292                            my @stackList = (@augmentedList, $toEntity);
1293                            push @fromPathList, \@stackList;
1294                        } else {
1295                            Trace("$toEntity ignored because it occurred previously.") if T(4);
1296                        }
1297                    }
1298                }
1299                # Now check the TO field. In this case only the relationship needs
1300                # deletion.
1301                if ($relationship->{to} eq $entityName) {
1302                    my @augmentedList = (@stackedPath, $entityName, $relationshipName);
1303                    push @toPathList, \@augmentedList;
1304                }
1305            }
1306        }
1307        # Create the first qualifier for the WHERE clause. This selects the
1308        # keys of the primary entity records to be deleted. When we're deleting
1309        # from a dependent table, we construct a join page from the first qualifier
1310        # to the table containing the dependent records to delete.
1311        my $qualifier = ($objectID =~ /%/ ? "LIKE ?" : "= ?");
1312        # We need to make two passes. The first is through the to-list, and
1313        # the second through the from-list. The from-list is second because
1314        # the to-list may need to pass through some of the entities the
1315        # from-list would delete.
1316        my %stackList = ( from_link => \@fromPathList, to_link => \@toPathList );
1317        # Now it's time to do the deletes. We do it in two passes.
1318        for my $keyName ('to_link', 'from_link') {
1319            # Get the list for this key.
1320            my @pathList = @{$stackList{$keyName}};
1321            Trace(scalar(@pathList) . " entries in path list for $keyName.") if T(3);
1322            # Loop through this list.
1323            while (my $path = pop @pathList) {
1324                # Get the table whose rows are to be deleted.
1325                my @pathTables = @{$path};
1326                # Start the DELETE statement. We need to call DBKernel because the
1327                # syntax of a DELETE-USING varies among DBMSs.
1328                my $target = $pathTables[$#pathTables];
1329                my $stmt = $db->SetUsing(@pathTables);
1330                # Now start the WHERE. The first thing is the ID field from the starting table. That
1331                # starting table will either be the entity relation or one of the entity's
1332                # sub-relations.
1333                $stmt .= " WHERE $pathTables[0].id $qualifier";
1334                # Now we run through the remaining entities in the path, connecting them up.
1335                for (my $i = 1; $i <= $#pathTables; $i += 2) {
1336                    # Connect the current relationship to the preceding entity.
1337                    my ($entity, $rel) = @pathTables[$i-1,$i];
1338                    # The style of connection depends on the direction of the relationship.
1339                    $stmt .= " AND $entity.id = $rel.$keyName";
1340                    if ($i + 1 <= $#pathTables) {
1341                        # Here there's a next entity, so connect that to the relationship's
1342                        # to-link.
1343                        my $entity2 = $pathTables[$i+1];
1344                        $stmt .= " AND $rel.to_link = $entity2.id";
1345                    }
1346                }
1347                # Now we have our desired DELETE statement.
1348                if ($testFlag) {
1349                    # Here the user wants to trace without executing.
1350                    Trace($stmt) if T(0);
1351                } else {
1352                    # Here we can delete. Note that the SQL method dies with a confessing
1353                    # if an error occurs, so we just go ahead and do it.
1354                    Trace("Executing delete from $target using '$objectID'.") if T(3);
1355                    my $rv = $db->SQL($stmt, 0, $objectID);
1356                    # Accumulate the statistics for this delete. The only rows deleted
1357                    # are from the target table, so we use its name to record the
1358                    # statistic.
1359                    $retVal->Add($target, $rv);
1360                }
1361            }
1362        }
1363        # Return the result.
1364      return $retVal;      return $retVal;
1365  }  }
1366    
# Line 1633  Line 2001 
2001      return $retVal;      return $retVal;
2002  }  }
2003    
2004    =head3 GetFieldTable
2005    
2006    C<< my $fieldHash = $self->GetFieldTable($objectnName); >>
2007    
2008    Get the field structure for a specified entity or relationship.
2009    
2010    =over 4
2011    
2012    =item objectName
2013    
2014    Name of the desired entity or relationship.
2015    
2016    =item RETURN
2017    
2018    The table containing the field descriptors for the specified object.
2019    
2020    =back
2021    
2022    =cut
2023    
2024    sub GetFieldTable {
2025        # Get the parameters.
2026        my ($self, $objectName) = @_;
2027        # Get the descriptor from the metadata.
2028        my $objectData = $self->_GetStructure($objectName);
2029        # Return the object's field table.
2030        return $objectData->{Fields};
2031    }
2032    
2033    =head3 GetUsefulCrossValues
2034    
2035    C<< my @attrNames = $sprout->GetUsefulCrossValues($sourceEntity, $relationship); >>
2036    
2037    Return a list of the useful attributes that would be returned by a B<Cross> call
2038    from an entity of the source entity type through the specified relationship. This
2039    means it will return the fields of the target entity type and the intersection data
2040    fields in the relationship. Only primary table fields are returned. In other words,
2041    the field names returned will be for fields where there is always one and only one
2042    value.
2043    
2044    =over 4
2045    
2046    =item sourceEntity
2047    
2048    Name of the entity from which the relationship crossing will start.
2049    
2050    =item relationship
2051    
2052    Name of the relationship being crossed.
2053    
2054    =item RETURN
2055    
2056    Returns a list of field names in Sprout field format (I<objectName>C<(>I<fieldName>C<)>.
2057    
2058    =back
2059    
2060    =cut
2061    #: Return Type @;
2062    sub GetUsefulCrossValues {
2063        # Get the parameters.
2064        my ($self, $sourceEntity, $relationship) = @_;
2065        # Declare the return variable.
2066        my @retVal = ();
2067        # Determine the target entity for the relationship. This is whichever entity is not
2068        # the source entity. So, if the source entity is the FROM, we'll get the name of
2069        # the TO, and vice versa.
2070        my $relStructure = $self->_GetStructure($relationship);
2071        my $targetEntityType = ($relStructure->{from} eq $sourceEntity ? "to" : "from");
2072        my $targetEntity = $relStructure->{$targetEntityType};
2073        # Get the field table for the entity.
2074        my $entityFields = $self->GetFieldTable($targetEntity);
2075        # The field table is a hash. The hash key is the field name. The hash value is a structure.
2076        # For the entity fields, the key aspect of the target structure is that the {relation} value
2077        # must match the entity name.
2078        my @fieldList = map { "$targetEntity($_)" } grep { $entityFields->{$_}->{relation} eq $targetEntity }
2079                            keys %{$entityFields};
2080        # Push the fields found onto the return variable.
2081        push @retVal, sort @fieldList;
2082        # Get the field table for the relationship.
2083        my $relationshipFields = $self->GetFieldTable($relationship);
2084        # Here we have a different rule. We want all the fields other than "from-link" and "to-link".
2085        # This may end up being an empty set.
2086        my @fieldList2 = map { "$relationship($_)" } grep { $_ ne "from-link" && $_ ne "to-link" }
2087                            keys %{$relationshipFields};
2088        # Push these onto the return list.
2089        push @retVal, sort @fieldList2;
2090        # Return the result.
2091        return @retVal;
2092    }
2093    
2094  =head2 Internal Utility Methods  =head2 Internal Utility Methods
2095    
2096  =head3 GetLoadStats  =head3 GetLoadStats
# Line 1839  Line 2297 
2297      return $objectData->{Relations};      return $objectData->{Relations};
2298  }  }
2299    
 =head3 GetFieldTable  
   
 Get the field structure for a specified entity or relationship.  
   
 This is an instance method.  
   
 =over 4  
   
 =item objectName  
   
 Name of the desired entity or relationship.  
   
 =item RETURN  
   
 The table containing the field descriptors for the specified object.  
   
 =back  
   
 =cut  
   
 sub _GetFieldTable {  
     # Get the parameters.  
     my ($self, $objectName) = @_;  
     # Get the descriptor from the metadata.  
     my $objectData = $self->_GetStructure($objectName);  
     # Return the object's field table.  
     return $objectData->{Fields};  
 }  
   
2300  =head3 ValidateFieldNames  =head3 ValidateFieldNames
2301    
2302  Determine whether or not the field names are valid. A description of the problems with the names  Determine whether or not the field names are valid. A description of the problems with the names
# Line 2221  Line 2650 
2650              # Determine if this relationship has our entity in one of its link fields.              # Determine if this relationship has our entity in one of its link fields.
2651              my $fromEntity = $relationship->{from};              my $fromEntity = $relationship->{from};
2652              my $toEntity = $relationship->{to};              my $toEntity = $relationship->{to};
2653              Trace("Join check for relationship $relationshipName from $fromEntity to $toEntity.") if T(4);              Trace("Join check for relationship $relationshipName from $fromEntity to $toEntity.") if T(Joins => 4);
2654              if ($fromEntity eq $entityName) {              if ($fromEntity eq $entityName) {
2655                  if ($toEntity eq $entityName) {                  if ($toEntity eq $entityName) {
2656                      # Here the relationship is recursive.                      # Here the relationship is recursive.
# Line 2310  Line 2739 
2739      return $metadata;      return $metadata;
2740  }  }
2741    
2742    =head3 SortNeeded
2743    
2744    C<< my $flag = $erdb->SortNeeded($relationName); >>
2745    
2746    Return TRUE if the specified relation should be sorted during loading to remove duplicate keys,
2747    else FALSE.
2748    
2749    =over 4
2750    
2751    =item relationName
2752    
2753    Name of the relation to be examined.
2754    
2755    =item RETURN
2756    
2757    Returns TRUE if the relation needs a sort, else FALSE.
2758    
2759    =back
2760    
2761    =cut
2762    #: Return Type $;
2763    sub SortNeeded {
2764        # Get the parameters.
2765        my ($self, $relationName) = @_;
2766        # Declare the return variable.
2767        my $retVal = 0;
2768        # Find out if the relation is a primary entity relation.
2769        my $entityTable = $self->{Entities};
2770        if (exists $entityTable->{$relationName}) {
2771            my $keyType = $entityTable->{$relationName}->{keyType};
2772            # If the key is not a hash string, we must do the sort.
2773            if ($keyType ne 'hash-string') {
2774                $retVal = 1;
2775            }
2776        }
2777        # Return the result.
2778        return $retVal;
2779    }
2780    
2781  =head3 CreateRelationshipIndex  =head3 CreateRelationshipIndex
2782    
2783  Create an index for a relationship's relation.  Create an index for a relationship's relation.
Legend:
Removed from v.1.30  
changed lines
  Added in v.1.42
MCS Webmaster
 ViewVC Help
Powered by ViewVC 1.0.3