[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.76, Wed Nov 15 12:08:26 2006 UTC revision 1.79, Wed Nov 29 20:29:53 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); >>  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 idea of dependence here is recursive. An object is  relationship instances dependent on it. The definition of I<dependence> is recursive.
1623  always dependent on itself. An object is dependent if it is a 1-to-many or many-to-many  
1624  relationship connected to a dependent entity or the "to" entity connected to a 1-to-many  An object is always dependent on itself. An object is dependent if it is a 1-to-many or many-to-many
1625    relationship connected to a dependent entity or if it is the "to" entity connected to a 1-to-many
1626  dependent relationship.  dependent relationship.
1627    
1628  =over 4  =over 4
# Line 1631  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 1642  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 1663  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 1674  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 1712  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 1759  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 {
1787                  # Here we can delete. Note that the SQL method dies with a confessing                  # Here we can delete. Note that the SQL method dies with a confession
1788                  # if an error occurs, so we just go ahead and do it.                  # if an error occurs, so we just go ahead and do it.
1789                  Trace("Executing delete from $target using '$objectID'.") if T(3);                  Trace("Executing delete from $target using '$objectID'.") if T(3);
1790                  my $rv = $db->SQL($stmt, 0, $objectID);                  my $rv = $db->SQL($stmt, 0, $objectID);
# Line 1778  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 DeleteRow
1856    
1857    C<< $erdb->DeleteRow($relationshipName, $fromLink, $toLink, \%values); >>
1858    
1859    Delete a row from a relationship. In most cases, only the from-link and to-link are
1860    needed; however, for relationships with intersection data values can be specified
1861    for the other fields using a hash.
1862    
1863    =over 4
1864    
1865    =item relationshipName
1866    
1867    Name of the relationship from which the row is to be deleted.
1868    
1869    =item fromLink
1870    
1871    ID of the entity instance in the From direction.
1872    
1873    =item toLink
1874    
1875    ID of the entity instance in the To direction.
1876    
1877    =item values
1878    
1879    Reference to a hash of other values to be used for filtering the delete.
1880    
1881    =back
1882    
1883    =cut
1884    
1885    sub DeleteRow {
1886        # Get the parameters.
1887        my ($self, $relationshipName, $fromLink, $toLink, $values) = @_;
1888        # Create a hash of all the filter information.
1889        my %filter = ('from-link' => $fromLink, 'to-link' => $toLink);
1890        if (defined $values) {
1891            for my $key (keys %{$values}) {
1892                $filter{$key} = $values->{$key};
1893            }
1894        }
1895        # Build an SQL statement out of the hash.
1896        my @filters = ();
1897        my @parms = ();
1898        for my $key (keys %filter) {
1899            push @filters, _FixName($key) . " = ?";
1900            push @parms, $filter{$key};
1901        }
1902        Trace("Parms for delete row are " . join(", ", map { "\"$_\"" } @parms) . ".") if T(SQL => 4);
1903        my $command = "DELETE FROM $relationshipName WHERE " .
1904                      join(" AND ", @filters);
1905        # Execute it.
1906        my $dbh = $self->{_dbh};
1907        $dbh->SQL($command, undef, @parms);
1908    }
1909    
1910  =head3 SortNeeded  =head3 SortNeeded
1911    
1912  C<< my $parms = $erdb->SortNeeded($relationName); >>  C<< my $parms = $erdb->SortNeeded($relationName); >>
# Line 2174  Line 2303 
2303    
2304  =head3 InsertObject  =head3 InsertObject
2305    
2306  C<< my $ok = $erdb->InsertObject($objectType, \%fieldHash); >>  C<< $erdb->InsertObject($objectType, \%fieldHash); >>
2307    
2308  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
2309  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 2200  Line 2329 
2329    
2330  Hash of field names to values.  Hash of field names to values.
2331    
 =item RETURN  
   
 Returns 1 if successful, 0 if an error occurred.  
   
2332  =back  =back
2333    
2334  =cut  =cut
# Line 2302  Line 2427 
2427                  $retVal = $sth->execute(@parameterList);                  $retVal = $sth->execute(@parameterList);
2428                  if (!$retVal) {                  if (!$retVal) {
2429                      my $errorString = $sth->errstr();                      my $errorString = $sth->errstr();
2430                      Trace("Insert error: $errorString.") if T(0);                      Confess("Error inserting into $relationName: $errorString");
2431                  }                  }
2432              }              }
2433          }          }
2434      }      }
2435      # Return the success indicator.      # Return a 1 for backward compatability.
2436      return $retVal;      return 1;
2437    }
2438    
2439    =head3 UpdateEntity
2440    
2441    C<< $erdb->UpdateEntity($entityName, $id, \%fields); >>
2442    
2443    Update the values of an entity. This is an unprotected update, so it should only be
2444    done if the database resides on a database server.
2445    
2446    =over 4
2447    
2448    =item entityName
2449    
2450    Name of the entity to update. (This is the entity type.)
2451    
2452    =item id
2453    
2454    ID of the entity to update. If no entity exists with this ID, an error will be thrown.
2455    
2456    =item fields
2457    
2458    Reference to a hash mapping field names to their new values. All of the fields named
2459    must be in the entity's primary relation, and they cannot any of them be the ID field.
2460    
2461    =back
2462    
2463    =cut
2464    
2465    sub UpdateEntity {
2466        # Get the parameters.
2467        my ($self, $entityName, $id, $fields) = @_;
2468        # Get a list of the field names being updated.
2469        my @fieldList = keys %{$fields};
2470        # Verify that the fields exist.
2471        my $checker = $self->GetFieldTable($entityName);
2472        for my $field (@fieldList) {
2473            if ($field eq 'id') {
2474                Confess("Cannot update the ID field for entity $entityName.");
2475            } elsif ($checker->{$field}->{relation} ne $entityName) {
2476                Confess("Cannot find $field in primary relation of $entityName.");
2477            }
2478        }
2479        # Build the SQL statement.
2480        my @sets = ();
2481        my @valueList = ();
2482        for my $field (@fieldList) {
2483            push @sets, _FixName($field) . " = ?";
2484            push @valueList, $fields->{$field};
2485        }
2486        my $command = "UPDATE $entityName SET " . join(", ", @sets) . " WHERE id = ?";
2487        # Add the ID to the list of binding values.
2488        push @valueList, $id;
2489        # Call SQL to do the work.
2490        my $rows = $self->{_dbh}->SQL($command, 0, @valueList);
2491        # Check for errors.
2492        if ($rows == 0) {
2493            Confess("Entity $id of type $entityName not found.");
2494        }
2495  }  }
2496    
2497  =head3 LoadTable  =head3 LoadTable
2498    
2499  C<< my %results = $erdb->LoadTable($fileName, $relationName, $truncateFlag); >>  C<< my $results = $erdb->LoadTable($fileName, $relationName, $truncateFlag); >>
2500    
2501  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
2502  first.  first.
# Line 2453  Line 2636 
2636      $dbh->drop_table(tbl => $relationName);      $dbh->drop_table(tbl => $relationName);
2637  }  }
2638    
2639    =head3 MatchSqlPattern
2640    
2641    C<< my $matched = ERDB::MatchSqlPattern($value, $pattern); >>
2642    
2643    Determine whether or not a specified value matches an SQL pattern. An SQL
2644    pattern has two wild card characters: C<%> that matches multiple characters,
2645    and C<_> that matches a single character. These can be escaped using a
2646    backslash (C<\>). We pull this off by converting the SQL pattern to a
2647    PERL regular expression. As per SQL rules, the match is case-insensitive.
2648    
2649    =over 4
2650    
2651    =item value
2652    
2653    Value to be matched against the pattern. Note that an undefined or empty
2654    value will not match anything.
2655    
2656    =item pattern
2657    
2658    SQL pattern against which to match the value. An undefined or empty pattern will
2659    match everything.
2660    
2661    =item RETURN
2662    
2663    Returns TRUE if the value and pattern match, else FALSE.
2664    
2665    =back
2666    
2667    =cut
2668    
2669    sub MatchSqlPattern {
2670        # Get the parameters.
2671        my ($value, $pattern) = @_;
2672        # Declare the return variable.
2673        my $retVal;
2674        # Insure we have a pattern.
2675        if (! defined($pattern) || $pattern eq "") {
2676            $retVal = 1;
2677        } else {
2678            # Break the pattern into pieces around the wildcard characters. Because we
2679            # use parentheses in the split function's delimiter expression, we'll get
2680            # list elements for the delimiters as well as the rest of the string.
2681            my @pieces = split /([_%]|\\[_%])/, $pattern;
2682            # Check some fast special cases.
2683            if ($pattern eq '%') {
2684                # A null pattern matches everything.
2685                $retVal = 1;
2686            } elsif (@pieces == 1) {
2687                # No wildcards, so we have a literal comparison. Note we're case-insensitive.
2688                $retVal = (lc($value) eq lc($pattern));
2689            } elsif (@pieces == 2 && $pieces[1] eq '%') {
2690                # A wildcard at the end, so we have a substring match. This is also case-insensitive.
2691                $retVal = (lc(substr($value, 0, length($pieces[0]))) eq lc($pieces[0]));
2692            } else {
2693                # Okay, we have to do it the hard way. Convert each piece to a PERL pattern.
2694                my $realPattern = "";
2695                for my $piece (@pieces) {
2696                    # Determine the type of piece.
2697                    if ($piece eq "") {
2698                        # Empty pieces are ignored.
2699                    } elsif ($piece eq "%") {
2700                        # Here we have a multi-character wildcard. Note that it can match
2701                        # zero or more characters.
2702                        $realPattern .= ".*"
2703                    } elsif ($piece eq "_") {
2704                        # Here we have a single-character wildcard.
2705                        $realPattern .= ".";
2706                    } elsif ($piece eq "\\%" || $piece eq "\\_") {
2707                        # This is an escape sequence (which is a rare thing, actually).
2708                        $realPattern .= substr($piece, 1, 1);
2709                    } else {
2710                        # Here we have raw text.
2711                        $realPattern .= quotemeta($piece);
2712                    }
2713                }
2714                # Do the match.
2715                $retVal = ($value =~ /^$realPattern$/i ? 1 : 0);
2716            }
2717        }
2718        # Return the result.
2719        return $retVal;
2720    }
2721    
2722  =head3 GetEntity  =head3 GetEntity
2723    
2724  C<< my $entityObject = $erdb->GetEntity($entityType, $ID); >>  C<< my $entityObject = $erdb->GetEntity($entityType, $ID); >>
# Line 2606  Line 2872 
2872  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
2873  feature ID followed by all of its aliases.  feature ID followed by all of its aliases.
2874    
2875  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)']); >>
2876    
2877  =over 4  =over 4
2878    
# Line 2860  Line 3126 
3126      # Declare the return variable. The field name is valid until we hear      # Declare the return variable. The field name is valid until we hear
3127      # differently.      # differently.
3128      my $retVal = 1;      my $retVal = 1;
3129        # Compute the maximum name length.
3130        my $maxLen = $TypeTable{'name-string'}->{maxLen};
3131      # Look for bad stuff in the name.      # Look for bad stuff in the name.
3132      if ($fieldName =~ /--/) {      if ($fieldName =~ /--/) {
3133          # Here we have a doubled minus sign.          # Here we have a doubled minus sign.
# Line 2869  Line 3137 
3137          # Here the field name is missing the initial letter.          # Here the field name is missing the initial letter.
3138          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);
3139          $retVal = 0;          $retVal = 0;
3140        } elsif (length($fieldName) > $maxLen) {
3141            # Here the field name is too long.
3142            Trace("Maximum field name length is $maxLen. Field name must be truncated to " . substr($fieldName,0, $maxLen) . ".");
3143      } else {      } else {
3144          # Strip out the minus signs. Everything remaining must be a letter,          # Strip out the minus signs. Everything remaining must be a letter,
3145          # underscore, or digit.          # underscore, or digit.

Legend:
Removed from v.1.76  
changed lines
  Added in v.1.79

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3