File Coverage

lib/Parse/Dia/SQL/Utils.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Parse::Dia::SQL::Utils;

# $Id: Utils.pm,v 1.13 2011/02/16 10:23:11 aff Exp $

=pod

=head1 NAME

Parse::Dia::SQL::Utils - Helper class for Parse::Dia::SQL.

=head1 SYNOPSIS

  Not to be used directly.

=head1 DESCRIPTION

Utility functions for Parse::Dia::SQL.

=cut

use warnings;
use strict;

use Data::Dumper;
use XML::DOM;
use Digest::MD5 qw(md5_base64);

use lib q{.};
use Parse::Dia::SQL::Logger;

# TODO: Move constants to a separate module
my %MAX_NAME_LEN = (
  default   => 30,
  db2       => 18,
  html      => 64,
  innodb    => 64,
  mysql     => 64,
  oracle    => 30,
  postgres  => 63,
  sas       => 32,
  sqlite3   => 60,
  sqlite3fk => 60,
);

# TODO: Make this a object variable
my $DEFAULT_PK = [];

=head2 set_default_pk

Define primary key column names and types for automatic generation of
primary keys in tables that need them, but do not have them defined.

=cut

sub set_default_pk {
  my $self = shift;
  if ( $self->{default_pk} ) {
    my @defPK = split /\s*:\s*/, $self->{default_pk};
    die "Bad definition of default primary key: $self->{default_pk}\n"
      if ( @defPK != 2 || $defPK[0] eq '' || $defPK[1] eq '' );
    my @pkNames = split /\s*,\s*/, $defPK[0];
    my @pkTypes = split /\s*,\s*/, $defPK[1];
    die
"Number of default primary key names and types don't match in $self->{default_pk}\n"
      if ( @pkNames != @pkTypes );
    foreach my $i ( 0 .. $#pkNames ) {
      my ( $name, $type ) = ( $pkNames[$i], $pkTypes[$i] );
      die "Null primary key name in " . $self->{default_pk} if ( !$name );
      die "Null primary key type in " . $self->{default_pk} if ( !$type );
      push @$DEFAULT_PK, [ $name, $type, 'not null', 2, '' ];
    }
  }
  return 1;
}


=head2 new

The constructor.  No arguments.

=cut

=head2 new


=cut

sub new {
  my ($class, %param) = @_;
  my $self = {
    log        => undef,
    db         => $param{db} || undef,
    default_pk => $param{default_pk} || undef,
    loglevel   => $param{loglevel} || undef,
  };

  bless($self, $class);

  # init logger
  my $logger = Parse::Dia::SQL::Logger::->new(loglevel => $self->{loglevel});
  $self->{log} = $logger->get_logger(__PACKAGE__);

  return $self;
}

=head2 get_node_attribute_values

Given a node with dia:attribute nodes inside it, go through the
dia:attribute nodes with attribute "name='...'" and return the string
values

@infosToGet is an array of strings, where the first character is the
data type to get, and the remaining characters are the name to parse
for. first character legal values are:

   a = alpha
   9 = numeric
   b = boolean

example:   aname, 9dollars, bkillOrNot

=cut

sub get_node_attribute_values {
  my ($self, $nodeList, @infosToGet) = @_;

  # TODO check datatype of nodeList

  my ( $currentNode, $nodeAttrName, $i );
  my %return;

  my $emptyValueString  = "__undef_string__";
  my $emptyValueNumber  = "__undef_numeric__";
  my $emptyValueBoolean = "__undef_boolean__";

  # initialise it to a bunch of empty values, this will also allow
  # us to know which attribute name values to parse out of the
  # dia:attribute nodelist
  foreach my $singleInfo (@infosToGet) {
    if ( $singleInfo =~ /^a(.+)/ ) {
      $return{$1} = $emptyValueString;
    }
    elsif ( $singleInfo =~ /^9(.+)/ ) {
      $return{$1} = $emptyValueNumber;
    }
    elsif ( $singleInfo =~ /^b(.+)/ ) {
      $return{$1} = $emptyValueBoolean;
    }
  }

  # we're interested in everything that's a dia:attribute
  my $attrNodeList = $nodeList->getElementsByTagName('dia:attribute');

  for ( $i = 0 ; $i < $attrNodeList->getLength ; $i++ ) {
    $currentNode  = $attrNodeList->item($i);
    $nodeAttrName = $currentNode->getAttribute('name');

    next if ( !$nodeAttrName || !$return{$nodeAttrName} );

    # test if this is a value we're interested in and if it's currently empty
    if ( $return{$nodeAttrName} eq $emptyValueString ) {

      # a text node gives us text
      $return{$nodeAttrName} = $self->get_string_from_node($currentNode);
    }
    elsif ( $return{$nodeAttrName} eq $emptyValueNumber ) {
      $return{$nodeAttrName} = $self->get_num_from_node($currentNode);
    }
    elsif ( $return{$nodeAttrName} eq $emptyValueBoolean ) {
      $return{$nodeAttrName} = $self->get_bool_from_node($currentNode);
    }
  }

	{
		no warnings q{uninitialized};
		$self->{log}->debug( "$nodeAttrName:" . $return{$nodeAttrName} );
	}

  # don't return some fake value for bits we didn't parse,
  # return undef which means it wasn't there
  foreach my $singleInfo (@infosToGet) {
    if (
         $singleInfo
      && $return{$singleInfo}
      && ( $return{$singleInfo} eq $emptyValueString
        || $return{$singleInfo} eq $emptyValueNumber
        || $return{$singleInfo} eq $emptyValueBoolean )
      )
    {
      $return{$singleInfo} = undef;
    }
  }

  return %return;
}


=head2 get_string_from_node

If it looks like value then
we will get the 'value' part out given the node is 'thingy'.

=cut

sub get_string_from_node {
  my $self = shift;
  my $node = shift;

  my $retval;

  my $stringVal;

  foreach my $stringNode ($node->getElementsByTagName('dia:string')) {
    if ($stringVal = $stringNode->getFirstChild) {
      $retval = $stringVal->toString;
    } else {
      $retval = "";
    }
  }

	return if !$retval; # Skip escaping if empty

  #	$retval =~ s/^#?(.*)#?$/$1/g;
  $retval =~ s/^#//;
  $retval =~ s/#$//;

  # TODO use HTML::Entities;
  # drTAE: also, XML files must escape certain sequences...
  $retval =~ s/</
  $retval =~ s/&/&/g;
  $retval =~ s/>/>/g;
  $retval =~ s/"/"/g;

  return $retval;
}

=head2 get_value_from_object

Given an object, node name, attribute name, attribute value, and value
to retrieve type, find the info and return it.

=cut

sub get_value_from_object {
  my $self                = shift;
  my $object              = shift;
  my $getNodeName         = shift;
  my $getNodeAttribute    = shift;
  my $getNodeAttributeVal = shift;
  my $infoToRetrieveType  = shift;

  my $parsedValue;
  my $currNode;

  if (
    $currNode = $self->get_node_from_object(
      $object,              $getNodeName, $getNodeAttribute,
      $getNodeAttributeVal
    )
    )
  {
    if ($infoToRetrieveType eq 'string') {
      $parsedValue = $self->get_string_from_node($currNode);
    } elsif ($infoToRetrieveType eq 'number') {
      $parsedValue = $self->get_num_from_node($currNode);
    } elsif ($infoToRetrieveType eq 'boolean') {
      $parsedValue = $self->get_bool_from_node($currNode);
    }

    return $parsedValue;
  } else {
    return;
  }
}

=head2 get_node_from_object

Given an object, node name, attribute name, and attribute value,
return the node that has all these things.

=cut

sub get_node_from_object {
  my $self                = shift;
  my $object              = shift;
  my $getNodeName         = shift;
  my $getNodeAttribute    = shift;
  my $getNodeAttributeVal = shift;

  my $k;
  my $doneParsing;
  my $parsedValue;

  my @nodeList = $object->getElementsByTagName($getNodeName);

  # search @nodeList for a getNodeAttribute="getNodeAttributeVal"
  foreach my $currNode (@nodeList) {
    if ($currNode->getNodeName eq $getNodeName) {
      my $attrPtr = $currNode->getAttributes;

      $k = 0;
      while (($k < $attrPtr->getLength) && !$doneParsing) {
        $parsedValue = $attrPtr->item($k)->toString;
        if ($parsedValue =~ /$getNodeAttribute="$getNodeAttributeVal"/) {
          return $currNode;
        }
        $k++;
      }
    }
  }

  # Not all nodes contain the wanted attribute
  return;
}

=head2 name_case

Transform case for name comparisons to that of the database; leave
unchanged if -C (preserve case) is in effect. Only sybase is known to
be case sensitive.

=cut

sub name_case {
  my ($self, $value) = @_;
  return '' unless $value;
  return $value if ($self->{opt_C} || $self->{db} eq 'sybase');
  return lc($value);    # Assumes that all other DBMSs ignore case of names!
}

=head2 get_num_from_node

Return value part of .

=cut

sub get_num_from_node {
  my ($self, $node) = @_;
	my $enumNode = shift @{$node->getElementsByTagName('dia:enum')};
	return $enumNode->getAttribute('val');
}

=head2 get_bool_from_node

Return value part of .

=cut

sub get_bool_from_node {
  my ($self, $node) = @_;
	my $enumNode = shift @{$node->getElementsByTagName('dia:boolean')};
	return $enumNode->getAttribute('val');
}


=head2 classify_multiplicity

Look at a multiplicity descriptor and classify it as 'one' (1, or
1..1), 'zone' (0..1), 'many' (n..m, n..*, where n > 1, m >= n) and
'zmany' (0..n, 0..*, where n > 1)

=cut

sub classify_multiplicity {
  my $self    = shift;
  my $multStr = shift;
  return 'none'  if ( ! $multStr );
  $multStr =~ s/\s//g;
  my @mult = split( /\.\./, $multStr );
  return 'none'  if ( @mult == 0 );
  return 'undef' if ( @mult > 2 );
  push @mult, $mult[0] if ( @mult == 1 );
  foreach my $m (@mult) {
    return 'undef' if ( $m !~ /^\d+$/ && $m ne '*' );
  }
  $mult[0] = 0            if ( $mult[0] eq '*' );
  $mult[1] = $mult[0] + 2 if ( $mult[1] eq '*' ); # ensure $mult[1] > 1 for 0..*
  return 'one'  if ( $mult[0] == 1 && $mult[1] == 1 );    # 1..1
  return 'zone' if ( $mult[0] == 0 && $mult[1] == 1 );    # 0..1
  return 'many'
    if (
    $mult[0] >= 1 && $mult[1] > 1                         # n..m, n..*,
    && $mult[0] <= $mult[1]
    );                                                    # n > 0, m > 1, m >= n
  return 'zmany' if ( $mult[0] == 0 && $mult[1] > 1 );    # 0..n, 0..*, n > 1
  return 'undef';
}


# =head2 parseExtras

# Parse the name of a Small Package that contains extra SQL clauses for
# the generated SQL, and add the SmallPackage text to the appropriate
# %tableExtras table for the type of extra clause (table, pk, index).

# =cut

# sub parseExtras {
#   my $self   = shift;
#   my $type   = shift;
#   my $params = shift;
#   my $dbText = shift;

#   my ($dbNames, $args) = split /\s*:\s*/, $params;
#   my $warns = 0;

#   return 0 if (!$args);

#   $args =~ s/\s//g;
#   $args =~ s/^[^(]*\(//;
#   $args =~ s/\)$//;

#   my @args = split /\s*,\s*/, $args;

#   if ($dbNames =~ /$opt_t/) {
#     foreach my $arg (@args) {
#       if (!$arg) {
#         warn "Null parameter in $params\n";
#         $warns++;
#         $errors++;
#         next;
#       }

#       if ($type =~ /^macro(.+)/) {
#         my $when = $1;
#         $macros{$arg} = { when => $when, sql => $dbText, used => 0 };
#         #if ($verbose) { print "Added $when Macro $arg\n"; }
#       } else {
#         my $dowarn = $tableExtras{$type}->{$arg};
#         if ($dowarn) {
#           warn "SQL clause for $type $arg redefined from\n"
#             . addExtraClauses('', $tableExtras{$type}->{$arg}, '    ');
#         }

#         $tableExtras{$type}->{$arg} = { sql => $dbText, used => 0 };
#         if ($dowarn) {
#           warn "to\n"
#             . addExtraClauses('', $tableExtras{$type}->{$arg}, '    ');
#         }
#       }
#     }
#   }

#   return $warns == 0;
# }

=head2 attlist_from_names

Generate a list of attributes from a comma-separated list of names by
looking up a class' attribute table.

=cut

sub attlist_from_names {
  my $self        = shift;
  my $classLookup = shift;
  my $nameStr     = shift;

  my @names = split /\s*,\s*/, $nameStr;
  my $attList = [];
  foreach my $n (@names) {
    my $a = $classLookup->{atts}{ $self->name_case($n) };
    push @$attList, $a if ($a);
  }
  return $attList;
}

=head2 names_from_attlist

Generate a comma-separated list of attribute names from a list of
attributes.

=cut

sub names_from_attlist {
  my $self = shift;
  my $atts = shift;
  return join ',', map { $_->[0] } @$atts;
}

=head2 check_att_list_types

Check that a list of primary key attributes has types corresponding to
the types in a list of foreign key attributes

=cut

sub check_att_list_types {
  my $self          = shift;
  my $assocName     = shift;
  my $classPKLookup = shift;
  my $classFKLookup = shift;
  my $PKatts        = shift;
  my $FKatts        = shift;
  my $db            = shift; # Parse::Dia::SQL::db

  if ( @$PKatts == 0 || @$PKatts != @$FKatts ) {
    $self->{log}->warn( "Attribute list empty or lengths don't match in"
      . " $assocName ($classPKLookup->{name},$classFKLookup->{name})");
    return 0;
  }
  my $mismatches = 0;

  # The types only exist if the classes are tables, not views
  if ( $classPKLookup->{type} eq 'table' && $classFKLookup->{type} eq 'table' )
  {
    foreach my $i ( 0 .. $#{$PKatts} ) {
	my $pktype = $self->get_base_type( $self->name_case( $PKatts->[$i][1] ), $db );
	my $fktype = $self->get_base_type( $self->name_case( $FKatts->[$i][1] ), $db );
      if ( $pktype ne $fktype )
      {
        $self->{log}->warn( "Attribute types"
          . " ($PKatts->[$i][0] is $PKatts->[$i][1],"
          . " $FKatts->[$i][0] is $FKatts->[$i][1])"
          . " don't match in $assocName"
          . " ($classPKLookup->{name},$classFKLookup->{name})");
        $mismatches++;
      }
    }
  }

  return $mismatches == 0;
}

=head2 get_base_type

Check that a list of primary key attributes has types corresponding to
the types in a list of foreign key attributes.

Returns base type of some DMBS specific types (eg in PostgreSQL serial
is integer).

AFF note:  This is better implemented in each sql formatter class.

=cut

sub get_base_type {
  my $self     = shift;
  my $typeName = shift;
  my $db       = shift;
  if ( $db eq 'postgres' ) {

    # handle PostgreSQL database type
    if ( lc($typeName) eq 'serial' or lc($typeName) eq 'int4' or lc($typeName) eq 'int') {
			$self->{log}->info(qq{Replaced $typeName with integer}) if $self->{log}->is_info();
      return 'integer';
    }
    if ( lc($typeName) eq 'smallserial' or lc($typeName) eq 'int2' ) {
			$self->{log}->info(qq{Replaced $typeName with smallint}) if $self->{log}->is_info();
      return 'smallint';
    }
    if ( lc($typeName) eq 'bigserial' or lc($typeName) eq 'int8' ) {
			$self->{log}->info(qq{Replaced $typeName with bigint}) if $self->{log}->is_info();
      return 'bigint';
    }

    return $typeName;
  }
  elsif ( $db eq 'templateDBMStype' ) {

    # handle this database type
    if ( $typeName eq 'templateDatatype' ) {
      return 'templateReturn';
    }
    return $typeName;
  }
  else {

    # all unhandled RDBMS types just return the typeName
    return $typeName;
  }
}



=head2 make_name

Generate a longer name from parts supplied. Except for the first part,
the first letter of each part is capitalised. If lcFirstWord is set,
then any initial string of capitals in the first part is made lower
case; otherwise the first part is left unchanged.

Dies if $self->{db} is not set.

The @parts_org values are save for "Desperation time" :)

=cut

sub make_name {
  my ( $self, $lcFirstWord, @parts_org ) = @_;
	my @parts =  @parts_org;
  my $namelen = undef;

  $self->{log}->logdie(q{Missing argument 'db'}) unless $self->{db};
  $self->{log}->debug(q{Make name from parts: } . join(q{,},@parts));

  if ( exists( $MAX_NAME_LEN{$self->{db}} ) ) {
    $namelen = $MAX_NAME_LEN{$self->{db}};
  }
  else {
    $namelen = $MAX_NAME_LEN{default};
    $self->{log}->warn(
      "The maximum name length for $self->{db} is not set - using default $namelen");
  }
	$self->{log}->debug("Using namelen $namelen");

  my $len = 0;
  foreach my $p (@parts) { $len += length($p); }

  # If maxNameLen is non-zero, then trim names down
  if ($namelen) {
    foreach my $p (@parts) {
      last if ( $len <= $namelen );
      $len -= length($p);

      # eliminate vowels
      while ( $p =~ /(.)[aeiouAEIOU]/ ) {
        $p =~ s/(.)[aeiouAEIOU]/$1/g;
      }
      while ( $p =~ /(.)\1/ ) {
        $p =~ s/(.)\1/$1/g;    # eliminate doubled letters
      }
      $len += length($p);
    }

    # This part cribbed from mangleName
    if ( $len > $namelen ) {
      my $frac = ( $namelen - $len + @parts ) / $namelen;
      foreach my $p (@parts) {
        last if ( $len <= $namelen );
        my $l    = length($p);
        my $skip = int( $frac * $l + 0.5 );
        my $pos  = int( ( $l - $skip ) / 2 + 0.5 );
        if ($skip) {
          $len -= $l;
          $p = substr( $p, 0, $pos ) . substr( $p, $pos + $skip );
          $len += length($p);
        }
      }
    }
    if ( $len > $namelen ) {

      # Desperation time!
      my $base64 = $self->name_scramble( join '', @parts_org );
			my $retval = substr( $base64, 0, $namelen );
			$self->{log}->debug(qq{Made name : $retval (premature return)});
      return $retval;
    }
  }

  # Remove dot, alows using postgres sql schemas - table name like shop.product
  if ( $self->{db} eq "postgres" ) {
    foreach my $p (@parts) {
      $p =~ s/\.//g;
    }
  }

  # Handle the lowercasing of the first part of the n ame

  if ($lcFirstWord) {
    $parts[0] =~ /([A-Z]*)(.*)/;
    my ( $firstPart, $lastPart ) = ( $1, $2 );
    if ($firstPart) {
      my $recapLast = length($firstPart) > 1
        && substr( $firstPart, -1 ) =~ /[A-Z]/
        && $parts[0] =~ /[a-z]/;
      $parts[0] = lc($firstPart);
      if ($recapLast) {
        $parts[0] = substr( $parts[0], 0, -1 ) . uc( substr( $parts[0], -1 ) );
      }
    }
    else {
      $parts[0] = '';
    }
    $parts[0] .= $lastPart if ($lastPart);
  }
  foreach my $p ( @parts[ 1 .. $#parts ] ) {
    $p = ucfirst($p);
  }

  $self->{log}->debug(q{Made name : } . join(q{},@parts));
  return join '', @parts;
}

=head2 name_scramble

PSuda: Name scrambling helper function, for code which auto-generates
names.  Takes one arg, which is string to use for md5 hashing. This
returns names which consist entirely of underscores and alphanumeric
characters, and starts with one or more alpha characters.

=cut

sub name_scramble {
  my $self = shift;
  my $base64 = md5_base64(shift);

  # Change non alphanumeric characters to underscores.
  $base64 =~ s/[^A-Za-z0-9_]/_/g;

  # Trim off numbers at the start, so that we don't wind up with names
  # that start with numbers. This is a problem in some instances in
  # MySQL.

  $base64 =~ s/^[^a-zA-Z]+//g;
  return $base64;
}


=head2 mangle_name

Get a name to mangle and mangle it to the length
specified -- avoid too much manglification if the
name is only slightly long, but mangle lots if it's
a lot longer than the specified length.

=cut

sub mangle_name {
  my $self           = shift;
  my $nameToMangle   = shift;
  my $sizeToMangleTo = shift;

  if (!(defined($nameToMangle) and defined($sizeToMangleTo) and $sizeToMangleTo =~ m/^\d+$/)){
    $self->{log}->error("Need a string and a positive integer");
    return;
  }

  # if it's already okay, just return it
  if ( length($nameToMangle) <= $sizeToMangleTo ) {
    return $nameToMangle;
  }

  my $newName;
  my $base64;

  # if it's a real long name, then we mangle it plenty
  if ( length($nameToMangle) > $sizeToMangleTo + 6 ) {
    $base64 = $self->name_scramble($nameToMangle);

    # ensure we have enough garbage
    while ( length($base64) < $sizeToMangleTo ) {
      $base64 .= $self->name_scramble ( $nameToMangle . $base64 );
    }

    $newName = substr( $base64, 0, $sizeToMangleTo );
  }
  elsif ( length($nameToMangle) > $sizeToMangleTo ) {

    # if it's just a little bit long, then mangle it less
    # (remove some chars from the middle)
    my $sizeDiv2  = $sizeToMangleTo / 2;
    my $mangleLen = length($nameToMangle);

    $newName = substr( $nameToMangle, 0, $sizeDiv2 );
    $newName .= substr( $nameToMangle, $mangleLen - $sizeDiv2, $sizeDiv2 );
  }

  return $newName;
}

=head2 add_default_pk

For -p - add a default primary key to a parsed table definition

TODO : Add a meaningful return value.

=cut

sub add_default_pk {
  my $self    = shift;
  my $pkClass = shift;
  my $pkStr   = shift;
  my $defPK   = [];

  if ($pkStr) {

    # If PK names are given, then use those names rather than
    # the default names; but take the types from the defaults
    my @pkNames = split /\s*,\s*/, $pkStr;
    if ( @pkNames == @$DEFAULT_PK ) {
      foreach my $i ( 0 .. $#pkNames ) {
        my $n      = $pkNames[$i];
        my $pkAtts = [ @{ $DEFAULT_PK->[$i] } ];
        $pkAtts->[0] = $n;
        push @$defPK, $pkAtts;
      }
    }
    else {
      warn
"Number of names in $pkStr does not match number of default PK attributes\n";
#      $errors++;
    }
  }
  else {

    # Otherwise just use the default names and types for the PK
    $defPK = $DEFAULT_PK;
  }

  # Add the PK attributes to the class; but complain if an attribute
  # is already defined; The PK fields are added at the beginning of the
  # list of attributes
  for ( my $i = $#{$defPK} ; $i >= 0 ; $i-- ) {
    my $pkAtts = $defPK->[$i];
    my $n      = $pkAtts->[0];
    if ( $pkClass->{atts}{ $self->name_case($n) } ) {
      warn
"In $pkClass->{name} $n is already an attribute; can't redefine it as a default primary key\n";
#      $errors++;
      next;
    }
    unshift @{ $pkClass->{attList} }, $pkAtts;
    $pkClass->{atts}{ $self->name_case($n) } = $pkAtts;
  }
  $pkClass->{pk} = $defPK;

	return 1; # Explicit return is a good practice
}

=head2 add_default_fk

For -f - add missing parts of a default foreign key to a parsed table
definition.

=cut

sub add_default_fk {
  my $self          = shift;
  my $fkClassLookup = shift;
  my $fkStr         = shift;
  my $fkAtts        = shift;
  my $pkAtts        = shift;
  my $nullClause    = shift;

  # Foreign key attributes may exist already; only create entries
  # for those not already there
  my @fkNames = split /\s*,\s*/, $fkStr;
  foreach my $i ( 0 .. $#{@fkNames} ) {
    if ( !$fkAtts->[$i]
      || $self->name_case( $fkAtts->[$i][0] ) ne $self->name_case( $fkNames[$i] ) )
    {

      # New FK has supplied name & supplied null clause,
      # and its other attributes (esp type) copied from its
      # corresponding primary key.
      my $newFK = [
        $fkNames[$i], $pkAtts->[$i][1],
        $nullClause, 0, @{$pkAtts}[ 4 .. $#{ $pkAtts->[$i] } ]
      ];
      splice @$fkAtts, $i, 0, $newFK;

      # add the new FK column to the end of the list of column defs
      push @{ $fkClassLookup->{attList} }, $newFK;
      $fkClassLookup->{atts}{ $self->name_case( $fkNames[$i] ) } = $newFK;
    }
  }
  return $fkAtts;
}


# Check that the given object and version is supported.  Return true
# on pass, undef on fail.
sub _check_object_version {
  my $self    = shift;
  my $type    = shift;
  my $version = int shift;    # can be zero, can have leading zeros

  if (!$type || !defined $version) {
    $self->{log}->error(qq{Need 2 args: type and version});
    return;
  }

  my %object_v = (
                  "UML - Association"  => [1,2],
                  "UML - Class"        => [0],
                  "UML - Component"    => [0],
                  "UML - Note"         => [0],
                  "UML - SmallPackage" => [0],
                 );

  $self->{log}->debug(qq{type:'$type' version:$version});

  if (!exists($object_v{$type})) {
    $self->{log}->debug(qq{type:'$type' unknown});
    return;
  }

  if (! grep(/^$version$/, @{$object_v{$type}})) {
    $self->{log}->debug(qq{type:'$type' version:$version unsupported});
    return;
  }

  return 1;
}

# Split a type definition 'type(nn)' into 'type', '(nn)'
sub split_type {
	my $self = shift;
	my $type = shift;

	if(!$type) {
		$self->{log}->warn("Missing type");
		return;
	}

	$type =~ m/^([^(]*)(\([^)]+\))?$/;
	my ($name, $size) = ($1, $2);
	if(!$name) {
		$self->{log}->warn("Malformed type name $type");
		return;
	}

	if ($size) {
		return ($name,$size);
	} else {
		return ($name);
	}
}

# =head2 parseExtras

# Parse the name of a Small Package that contains extra SQL clauses for
# the generated SQL, and add the SmallPackage text to the appropriate
# %tableExtras table for the type of extra clause (table, pk, index).

# =cut

# sub parseExtras {
#   my $self   = shift;
#   my $type   = shift;
#   my $params = shift;
#   my $dbText = shift;

#   my ($dbNames, $args) = split /\s*:\s*/, $params;
#   my $warns = 0;

#   return 0 if (!$args);

#   $args =~ s/\s//g;
#   $args =~ s/^[^(]*\(//;
#   $args =~ s/\)$//;

#   my @args = split /\s*,\s*/, $args;

#   if ($dbNames =~ /$opt_t/) {
#     foreach my $arg (@args) {
#       if (!$arg) {
#         warn "Null parameter in $params\n";
#         $warns++;
#         $errors++;
#         next;
#       }

#       if ($type =~ /^macro(.+)/) {
#         my $when = $1;
#         $macros{$arg} = { when => $when, sql => $dbText, used => 0 };
#         #if ($verbose) { print "Added $when Macro $arg\n"; }
#       } else {
#         my $dowarn = $tableExtras{$type}->{$arg};
#         if ($dowarn) {
#           warn "SQL clause for $type $arg redefined from\n"
#             . addExtraClauses('', $tableExtras{$type}->{$arg}, '    ');
#         }

#         $tableExtras{$type}->{$arg} = { sql => $dbText, used => 0 };
#         if ($dowarn) {
#           warn "to\n"
#             . addExtraClauses('', $tableExtras{$type}->{$arg}, '    ');
#         }
#       }
#     }
#   }

#   return $warns == 0;
# }

1;

__END__