[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.77, Mon Nov 20 05:53:02 2006 UTC revision 1.78, Tue Nov 28 01:02:42 2006 UTC
# Line 257  Line 257 
257    
258  =back  =back
259    
260  The B<Index>, B<FromIndex>, and B<ToIndex> tags themselves have no attributes.  The B<FromIndex>, and B<ToIndex> tags have no attributes. The B<Index> tag can
261    have a B<Unique> attribute. If specified, the index will be generated as a unique
262    index.
263    
264  =head3 Object and Field Names  =head3 Object and Field Names
265    
# Line 394  Line 396 
396                   );                   );
397    
398  my %XmlInOpts  = (  my %XmlInOpts  = (
399                    ForceArray => ['Field', 'Index', 'IndexField'],                    ForceArray => ['Field', 'Index', 'IndexField', 'Relationship', 'Entity'],
400                    ForceContent => 1,                    ForceContent => 1,
401                    NormalizeSpace => 2,                    NormalizeSpace => 2,
402                   );                   );
# Line 966  Line 968 
968          my @rawFields = @{$indexData->{IndexFields}};          my @rawFields = @{$indexData->{IndexFields}};
969          # Get a hash of the relation's field types.          # Get a hash of the relation's field types.
970          my %types = map { $_->{name} => $_->{type} } @{$relationData->{Fields}};          my %types = map { $_->{name} => $_->{type} } @{$relationData->{Fields}};
971          # We need to check for text fields. We need a append a length limitation for them. To do          # We need to check for text fields so we can append a length limitation for them. To do
972          # that, we need the relation's field list.          # that, we need the relation's field list.
973          my $relFields = $relationData->{Fields};          my $relFields = $relationData->{Fields};
974          for (my $i = 0; $i <= $#rawFields; $i++) {          for (my $i = 0; $i <= $#rawFields; $i++) {
# Line 1418  Line 1420 
1420      return $retVal;      return $retVal;
1421  }  }
1422    
1423    
1424    
1425  =head3 Search  =head3 Search
1426    
1427  C<< my $query = $erdb->Search($searchExpression, $idx, \@objectNames, $filterClause, \@params); >>  C<< my $query = $erdb->Search($searchExpression, $idx, \@objectNames, $filterClause, \@params); >>
# Line 1612  Line 1616 
1616    
1617  =head3 Delete  =head3 Delete
1618    
1619  C<< my $stats = $erdb->Delete($entityName, $objectID, $testFlag); >>  C<< my $stats = $erdb->Delete($entityName, $objectID, %options); >>
1620    
1621  Delete an entity instance from the database. The instance is deleted along with all entity and  Delete an entity instance from the database. The instance is deleted along with all entity and
1622  relationship instances dependent on it. The definition of I<dependence> is recursive.  relationship instances dependent on it. The definition of I<dependence> is recursive.
# Line 1632  Line 1636 
1636  ID of the entity instance to be deleted. If the ID contains a wild card character (C<%>),  ID of the entity instance to be deleted. If the ID contains a wild card character (C<%>),
1637  then it is presumed to by a LIKE pattern.  then it is presumed to by a LIKE pattern.
1638    
1639  =item testFlag  =item options
1640    
1641  If TRUE, the delete statements will be traced without being executed.  A hash detailing the options for this delete operation.
1642    
1643  =item RETURN  =item RETURN
1644    
# Line 1643  Line 1647 
1647    
1648  =back  =back
1649    
1650    The permissible options for this method are as follows.
1651    
1652    =over 4
1653    
1654    =item testMode
1655    
1656    If TRUE, then the delete statements will be traced, but no changes will be made to the database.
1657    
1658    =item keepRoot
1659    
1660    If TRUE, then the entity instances will not be deleted, only the dependent records.
1661    
1662    =back
1663    
1664  =cut  =cut
1665  #: Return Type $%;  #: Return Type $%;
1666  sub Delete {  sub Delete {
1667      # Get the parameters.      # Get the parameters.
1668      my ($self, $entityName, $objectID, $testFlag) = @_;      my ($self, $entityName, $objectID, %options) = @_;
1669      # Declare the return variable.      # Declare the return variable.
1670      my $retVal = Stats->new();      my $retVal = Stats->new();
1671      # Get the DBKernel object.      # Get the DBKernel object.
# Line 1664  Line 1682 
1682      # FROM-relationships and entities.      # FROM-relationships and entities.
1683      my @fromPathList = ();      my @fromPathList = ();
1684      my @toPathList = ();      my @toPathList = ();
1685      # This final hash is used to remember what work still needs to be done. We push paths      # This final list is used to remember what work still needs to be done. We push paths
1686      # onto the list, then pop them off to extend the paths. We prime it with the starting      # onto the list, then pop them off to extend the paths. We prime it with the starting
1687      # point. Note that we will work hard to insure that the last item on a path in the      # point. Note that we will work hard to insure that the last item on a path in the
1688      # to-do list is always an entity.      # to-do list is always an entity.
# Line 1675  Line 1693 
1693          # Copy it into a list.          # Copy it into a list.
1694          my @stackedPath = @{$current};          my @stackedPath = @{$current};
1695          # Pull off the last item on the path. It will always be an entity.          # Pull off the last item on the path. It will always be an entity.
1696          my $entityName = pop @stackedPath;          my $myEntityName = pop @stackedPath;
1697          # Add it to the alreadyFound list.          # Add it to the alreadyFound list.
1698          $alreadyFound{$entityName} = 1;          $alreadyFound{$myEntityName} = 1;
1699            # Figure out if we need to delete this entity.
1700            if ($myEntityName ne $entityName || ! $options{keepRoot}) {
1701          # Get the entity data.          # Get the entity data.
1702          my $entityData = $self->_GetStructure($entityName);              my $entityData = $self->_GetStructure($myEntityName);
1703          # The first task is to loop through the entity's relation. A DELETE command will              # Loop through the entity's relations. A DELETE command will be needed for each of them.
         # be needed for each of them.  
1704          my $relations = $entityData->{Relations};          my $relations = $entityData->{Relations};
1705          for my $relation (keys %{$relations}) {          for my $relation (keys %{$relations}) {
1706              my @augmentedList = (@stackedPath, $relation);              my @augmentedList = (@stackedPath, $relation);
1707              push @fromPathList, \@augmentedList;              push @fromPathList, \@augmentedList;
1708          }          }
1709            }
1710          # Now we need to look for relationships connected to this entity.          # Now we need to look for relationships connected to this entity.
1711          my $relationshipList = $self->{_metaData}->{Relationships};          my $relationshipList = $self->{_metaData}->{Relationships};
1712          for my $relationshipName (keys %{$relationshipList}) {          for my $relationshipName (keys %{$relationshipList}) {
1713              my $relationship = $relationshipList->{$relationshipName};              my $relationship = $relationshipList->{$relationshipName};
1714              # Check the FROM field. We're only interested if it's us.              # Check the FROM field. We're only interested if it's us.
1715              if ($relationship->{from} eq $entityName) {              if ($relationship->{from} eq $myEntityName) {
1716                  # Add the path to this relationship.                  # Add the path to this relationship.
1717                  my @augmentedList = (@stackedPath, $entityName, $relationshipName);                  my @augmentedList = (@stackedPath, $myEntityName, $relationshipName);
1718                  push @fromPathList, \@augmentedList;                  push @fromPathList, \@augmentedList;
1719                  # Check the arity. If it's MM we're done. If it's 1M                  # Check the arity. If it's MM we're done. If it's 1M
1720                  # and the target hasn't been seen yet, we want to                  # and the target hasn't been seen yet, we want to
# Line 1713  Line 1733 
1733              }              }
1734              # Now check the TO field. In this case only the relationship needs              # Now check the TO field. In this case only the relationship needs
1735              # deletion.              # deletion.
1736              if ($relationship->{to} eq $entityName) {              if ($relationship->{to} eq $myEntityName) {
1737                  my @augmentedList = (@stackedPath, $entityName, $relationshipName);                  my @augmentedList = (@stackedPath, $myEntityName, $relationshipName);
1738                  push @toPathList, \@augmentedList;                  push @toPathList, \@augmentedList;
1739              }              }
1740          }          }
1741      }      }
1742      # Create the first qualifier for the WHERE clause. This selects the      # Create the first qualifier for the WHERE clause. This selects the
1743      # keys of the primary entity records to be deleted. When we're deleting      # keys of the primary entity records to be deleted. When we're deleting
1744      # from a dependent table, we construct a join page from the first qualifier      # from a dependent table, we construct a join path from the first qualifier
1745      # to the table containing the dependent records to delete.      # to the table containing the dependent records to delete.
1746      my $qualifier = ($objectID =~ /%/ ? "LIKE ?" : "= ?");      my $qualifier = ($objectID =~ /%/ ? "LIKE ?" : "= ?");
1747      # We need to make two passes. The first is through the to-list, and      # We need to make two passes. The first is through the to-list, and
# Line 1760  Line 1780 
1780                  }                  }
1781              }              }
1782              # Now we have our desired DELETE statement.              # Now we have our desired DELETE statement.
1783              if ($testFlag) {              if ($options{testMode}) {
1784                  # Here the user wants to trace without executing.                  # Here the user wants to trace without executing.
1785                  Trace($stmt) if T(0);                  Trace($stmt) if T(0);
1786              } else {              } else {
# Line 1779  Line 1799 
1799      return $retVal;      return $retVal;
1800  }  }
1801    
1802    =head3 Disconnect
1803    
1804    C<< $erdb->Disconnect($relationshipName, $originEntityName, $originEntityID); >>
1805    
1806    Disconnect an entity instance from all the objects to which it is related. This
1807    will delete each relationship instance that connects to the specified entity.
1808    
1809    =over 4
1810    
1811    =item relationshipName
1812    
1813    Name of the relationship whose instances are to be deleted.
1814    
1815    =item originEntityName
1816    
1817    Name of the entity that is to be disconnected.
1818    
1819    =item originEntityID
1820    
1821    ID of the entity that is to be disconnected.
1822    
1823    =back
1824    
1825    =cut
1826    
1827    sub Disconnect {
1828        # Get the parameters.
1829        my ($self, $relationshipName, $originEntityName, $originEntityID) = @_;
1830        # Get the relationship descriptor.
1831        my $structure = $self->_GetStructure($relationshipName);
1832        # Insure we have a relationship.
1833        if (! exists $structure->{from}) {
1834            Confess("$relationshipName is not a relationship in the database.");
1835        } else {
1836            # Get the database handle.
1837            my $dbh = $self->{_dbh};
1838            # We'll set this value to 1 if we find our entity.
1839            my $found = 0;
1840            # Loop through the ends of the relationship.
1841            for my $dir ('from', 'to') {
1842                if ($structure->{$dir} eq $originEntityName) {
1843                    # Delete all relationship instances on this side of the entity instance.
1844                    $dbh->SQL("DELETE FROM $relationshipName WHERE ${dir}_link = ?", 0, $originEntityID);
1845                    $found = 1;
1846                }
1847            }
1848            # Insure we found the entity on at least one end.
1849            if (! $found) {
1850                Confess("Entity \"$originEntityName\" does not use $relationshipName.");
1851            }
1852        }
1853    }
1854    
1855  =head3 SortNeeded  =head3 SortNeeded
1856    
1857  C<< my $parms = $erdb->SortNeeded($relationName); >>  C<< my $parms = $erdb->SortNeeded($relationName); >>
# Line 2175  Line 2248 
2248    
2249  =head3 InsertObject  =head3 InsertObject
2250    
2251  C<< my $ok = $erdb->InsertObject($objectType, \%fieldHash); >>  C<< $erdb->InsertObject($objectType, \%fieldHash); >>
2252    
2253  Insert an object into the database. The object is defined by a type name and then a hash  Insert an object into the database. The object is defined by a type name and then a hash
2254  of field names to values. Field values in the primary relation are represented by scalars.  of field names to values. Field values in the primary relation are represented by scalars.
# Line 2201  Line 2274 
2274    
2275  Hash of field names to values.  Hash of field names to values.
2276    
 =item RETURN  
   
 Returns 1 if successful, 0 if an error occurred.  
   
2277  =back  =back
2278    
2279  =cut  =cut
# Line 2303  Line 2372 
2372                  $retVal = $sth->execute(@parameterList);                  $retVal = $sth->execute(@parameterList);
2373                  if (!$retVal) {                  if (!$retVal) {
2374                      my $errorString = $sth->errstr();                      my $errorString = $sth->errstr();
2375                      Trace("Insert error: $errorString.") if T(0);                      Confess("Error inserting into $relationName: $errorString");
2376                  }                  }
2377              }              }
2378          }          }
2379      }      }
2380      # Return the success indicator.      # Return a 1 for backward compatability.
2381      return $retVal;      return 1;
2382    }
2383    
2384    =head3 UpdateEntity
2385    
2386    C<< $erdb->UpdateEntity($entityName, $id, \%fields); >>
2387    
2388    Update the values of an entity. This is an unprotected update, so it should only be
2389    done if the database resides on a database server.
2390    
2391    =over 4
2392    
2393    =item entityName
2394    
2395    Name of the entity to update. (This is the entity type.)
2396    
2397    =item id
2398    
2399    ID of the entity to update. If no entity exists with this ID, an error will be thrown.
2400    
2401    =item fields
2402    
2403    Reference to a hash mapping field names to their new values. All of the fields named
2404    must be in the entity's primary relation, and they cannot any of them be the ID field.
2405    
2406    =back
2407    
2408    =cut
2409    
2410    sub UpdateEntity {
2411        # Get the parameters.
2412        my ($self, $entityName, $id, $fields) = @_;
2413        # Get a list of the field names being updated.
2414        my @fieldList = keys %{$fields};
2415        # Verify that the fields exist.
2416        my $checker = $self->GetFieldTable($entityName);
2417        for my $field (@fieldList) {
2418            if ($field eq 'id') {
2419                Confess("Cannot update the ID field for entity $entityName.");
2420            } elsif ($checker->{$field}->{relation} ne $entityName) {
2421                Confess("Cannot find $field in primary relation of $entityName.");
2422            }
2423        }
2424        # Build the SQL statement.
2425        my @sets = ();
2426        my @valueList = ();
2427        for my $field (@fieldList) {
2428            push @sets, _FixName($field) . " = ?";
2429            push @valueList, $fields->{$field};
2430        }
2431        my $command = "UPDATE $entityName SET " . join(", ", @sets) . " WHERE id = ?";
2432        # Add the ID to the list of binding values.
2433        push @valueList, $id;
2434        # Call SQL to do the work.
2435        my $rows = $self->{_dbh}->SQL($command, 0, @valueList);
2436        # Check for errors.
2437        if ($rows == 0) {
2438            Confess("Entity $id of type $entityName not found.");
2439        }
2440  }  }
2441    
2442  =head3 LoadTable  =head3 LoadTable
2443    
2444  C<< my %results = $erdb->LoadTable($fileName, $relationName, $truncateFlag); >>  C<< my $results = $erdb->LoadTable($fileName, $relationName, $truncateFlag); >>
2445    
2446  Load data from a tab-delimited file into a specified table, optionally re-creating the table  Load data from a tab-delimited file into a specified table, optionally re-creating the table
2447  first.  first.
# Line 2454  Line 2581 
2581      $dbh->drop_table(tbl => $relationName);      $dbh->drop_table(tbl => $relationName);
2582  }  }
2583    
2584    =head3 MatchSqlPattern
2585    
2586    C<< my $matched = ERDB::MatchSqlPattern($value, $pattern); >>
2587    
2588    Determine whether or not a specified value matches an SQL pattern. An SQL
2589    pattern has two wild card characters: C<%> that matches multiple characters,
2590    and C<_> that matches a single character. These can be escaped using a
2591    backslash (C<\>). We pull this off by converting the SQL pattern to a
2592    PERL regular expression. As per SQL rules, the match is case-insensitive.
2593    
2594    =over 4
2595    
2596    =item value
2597    
2598    Value to be matched against the pattern. Note that an undefined or empty
2599    value will not match anything.
2600    
2601    =item pattern
2602    
2603    SQL pattern against which to match the value. An undefined or empty pattern will
2604    match everything.
2605    
2606    =item RETURN
2607    
2608    Returns TRUE if the value and pattern match, else FALSE.
2609    
2610    =back
2611    
2612    =cut
2613    
2614    sub MatchSqlPattern {
2615        # Get the parameters.
2616        my ($value, $pattern) = @_;
2617        # Declare the return variable.
2618        my $retVal;
2619        # Insure we have a pattern.
2620        if (! defined($pattern) || $pattern eq "") {
2621            $retVal = 1;
2622        } else {
2623            # Break the pattern into pieces around the wildcard characters. Because we
2624            # use parentheses in the split function's delimiter expression, we'll get
2625            # list elements for the delimiters as well as the rest of the string.
2626            my @pieces = split /([_%]|\\[_%])/, $pattern;
2627            # Check some fast special cases.
2628            if ($pattern eq '%') {
2629                # A null pattern matches everything.
2630                $retVal = 1;
2631            } elsif (@pieces == 1) {
2632                # No wildcards, so we have a literal comparison. Note we're case-insensitive.
2633                $retVal = (lc($value) eq lc($pattern));
2634            } elsif (@pieces == 2 && $pieces[1] eq '%') {
2635                # A wildcard at the end, so we have a substring match. This is also case-insensitive.
2636                $retVal = (lc(substr($value, 0, length($pieces[0]))) eq lc($pieces[0]));
2637            } else {
2638                # Okay, we have to do it the hard way. Convert each piece to a PERL pattern.
2639                my $realPattern = "";
2640                for my $piece (@pieces) {
2641                    # Determine the type of piece.
2642                    if ($piece eq "") {
2643                        # Empty pieces are ignored.
2644                    } elsif ($piece eq "%") {
2645                        # Here we have a multi-character wildcard. Note that it can match
2646                        # zero or more characters.
2647                        $realPattern .= ".*"
2648                    } elsif ($piece eq "_") {
2649                        # Here we have a single-character wildcard.
2650                        $realPattern .= ".";
2651                    } elsif ($piece eq "\\%" || $piece eq "\\_") {
2652                        # This is an escape sequence (which is a rare thing, actually).
2653                        $realPattern .= substr($piece, 1, 1);
2654                    } else {
2655                        # Here we have raw text.
2656                        $realPattern .= quotemeta($piece);
2657                    }
2658                }
2659                # Do the match.
2660                $retVal = ($value =~ /^$realPattern$/i ? 1 : 0);
2661            }
2662        }
2663        # Return the result.
2664        return $retVal;
2665    }
2666    
2667  =head3 GetEntity  =head3 GetEntity
2668    
2669  C<< my $entityObject = $erdb->GetEntity($entityType, $ID); >>  C<< my $entityObject = $erdb->GetEntity($entityType, $ID); >>
# Line 2607  Line 2817 
2817  spreadsheet cell, and each feature will be represented by a list containing the  spreadsheet cell, and each feature will be represented by a list containing the
2818  feature ID followed by all of its aliases.  feature ID followed by all of its aliases.
2819    
2820  C<< $query = $erdb->Get(['ContainsFeature', 'Feature'], "ContainsFeature(from-link) = ?", [$ssCellID], ['Feature(id)', 'Feature(alias)']); >>  C<< @query = $erdb->Get(['ContainsFeature', 'Feature'], "ContainsFeature(from-link) = ?", [$ssCellID], ['Feature(id)', 'Feature(alias)']); >>
2821    
2822  =over 4  =over 4
2823    
# Line 2861  Line 3071 
3071      # Declare the return variable. The field name is valid until we hear      # Declare the return variable. The field name is valid until we hear
3072      # differently.      # differently.
3073      my $retVal = 1;      my $retVal = 1;
3074        # Compute the maximum name length.
3075        my $maxLen = $TypeTable{'name-string'}->{maxLen};
3076      # Look for bad stuff in the name.      # Look for bad stuff in the name.
3077      if ($fieldName =~ /--/) {      if ($fieldName =~ /--/) {
3078          # Here we have a doubled minus sign.          # Here we have a doubled minus sign.
# Line 2870  Line 3082 
3082          # Here the field name is missing the initial letter.          # Here the field name is missing the initial letter.
3083          Trace("Field name $fieldName does not begin with a letter.") if T(1);          Trace("Field name $fieldName does not begin with a letter.") if T(1);
3084          $retVal = 0;          $retVal = 0;
3085        } elsif (length($fieldName) > $maxLen) {
3086            # Here the field name is too long.
3087            Trace("Maximum field name length is $maxLen. Field name must be truncated to " . substr($fieldName,0, $maxLen) . ".");
3088      } else {      } else {
3089          # Strip out the minus signs. Everything remaining must be a letter,          # Strip out the minus signs. Everything remaining must be a letter,
3090          # underscore, or digit.          # underscore, or digit.

Legend:
Removed from v.1.77  
changed lines
  Added in v.1.78

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3