view release on metacpan or  search on metacpan

lib/Parse/Dia/SQL.pm  view on Meta::CPAN

      . " ($leftClassLookup->{name},$rightClassLookup->{name} ne 'table')"
      . ": Many-to-many associations are only supported between tables");
#    $errors++;
    return;
  }

  # Generate the centre (join) table name if the user hasn't specified one

  $assocName =
    $self->{utils}->make_name( 0, $leftClassLookup->{name}, $rightClassLookup->{name}, $self->{db} )
    if ( !$assocName );

  # Build the centre table for the left (A) end of the association

  if (
    !$self->add_centre_cols(
      $assocName,   \@centreCols, $leftRole,     $rightRole,
      \$leftFKName, \$leftFKCols, \$leftEndCols, $leftClassLookup
    )
    )
  {
    $self->{log}->debug("add_centre_cols return false - returning");
    return;
  }

  # Build the centre table for the right (B) end of the association

  if (
    !$self->add_centre_cols(
      $assocName,    \@centreCols,  $rightRole,     $leftRole,
      \$rightFKName, \$rightFKCols, \$rightEndCols, $rightClassLookup
    )
    )
  {
    $self->{log}->debug("add_centre_cols return false - returning");
    return;
  }

  # Make the association table
  $self->{log}->debug("Call gen_table_view_sql assocName=$assocName");

  $self->gen_table_view_sql(
    $assocName,
    "table",
    "Association between $leftClassLookup->{name}"
      . " and $rightClassLookup->{name}",
    [@centreCols],
    []
  );

  # generate the constraint code:
  # foreign key -> referenced attribute
  $self->{log}->debug("Call save_foreign_key (left to right)");

  $self->save_foreign_key(
    $assocName,                  ## From table
    $leftFKName,                 ## name of foreign key constraint
    $leftFKCols,                 ## foreign key column in assoc tbl
    $leftClassLookup->{name},    ## Table referenced
    $leftEndCols,                ## Column in table referenced
    'on delete cascade'          ## Trash when no longer referenced
  );

  # generate the constraint code:
  # referenced attribute <- foreign key
  $self->{log}->debug("Call save_foreign_key (right to left)");

  $self->save_foreign_key($assocName, $rightFKName, $rightFKCols,
    $rightClassLookup->{name},
    $rightEndCols, 'on delete cascade');

  return 1;
}

# Create datastructure that represents given Table or View SQL and
# store in classes reference.
sub gen_table_view_sql {
  my $self             = shift;
  my $objectName       = shift;
  my $objectType       = shift;
  my $objectComment    = shift;
  my $objectAttributes = shift;
  my $objectOperations = shift;

  my $classLookup = {
    name    => $objectName,    # Object name
    type    => $objectType,    # Object type table/view
    attList => $objectAttributes,            # list of attributes
    atts    => $objectAttributes,            # lookup table of attributes
    pk      => [],            # list of primary key attributes
    uindxc  => {},            # lookup of unique index column names
    uindxn  => {},            # lookup of unique index names
    ops     => $objectOperations,            # list of operations
  };

  # Push this generated table to classes array
  push @{ $self->{classes} }, $classLookup;

  $self->{log}->debug("classes: ".Dumper($self->{classes}));

  return 1;
}

# Add column descriptors for a centre (join) table to an array of
# descriptors passed.
sub add_centre_cols {
  my $self       = shift;
  my $assocName  = shift;  # For warning messages & constructing constraint name
  my $cols       = shift;  # Where to add column descriptors
  my $pkRole     = shift;  # Names for the PK end
  my $fkRole     = shift;  # Names for the FK end
  my $fkCName    = shift;  # Assemble FK constraint name here
  my $fkColNames = shift;  # Assemble FK column names here
  my $pkColNames = shift;  # Assemble PK column names here
  my $classDesc  = shift;  # Class lookup descriptor

  my $className = $classDesc->{name};     # Name of target class
  my $pk        = $classDesc->{pk};       # List of primary key attributes
  my $uin       = $classDesc->{uindxn};   # List of unique index by name
  my $uic       = $classDesc->{uindxc};   # List of unique index by column names

  my ( undef, $pkRoleNames ) = split( /\s*:\s*/, $pkRole );
  my ( $fkRoleNames, undef ) = split( /\s*:\s*/, $fkRole );

  my $pkAtts = $pk;

  # Use user-supplied names for the primary key if given

  if ($pkRoleNames) {
    $pkRoleNames =~ s/\s//g;

lib/Parse/Dia/SQL.pm  view on Meta::CPAN

# Generate data for SQL generation for an association where one side has
# multiplicity one; no additional table is necessary.
sub generate_one_to_any_association {
  my $self          = shift;
  my $userAssocName = shift;
  my $pkSide        = shift;
  my $arity         = shift;
  my $pkClassLookup = shift;
  my $pkEnd         = shift;
  my $fkClassLookup = shift;
  my $fkEnd         = shift;

  # The caller used 'left' and 'right'; change this to
  # primary key/foreign key side of the association

  if ( $pkSide eq 'right' ) {
    my $tClassLookup = $pkClassLookup;
    my $tEnd         = $pkEnd;
    $pkClassLookup = $fkClassLookup;
    $pkEnd         = $fkEnd;
    $fkClassLookup = $tClassLookup;
    $fkEnd         = $tEnd;
  }

  # MAke the association name if necessary

  my $assocName = $userAssocName;
  if ( !$assocName ) {
    $assocName = $self->{utils}->make_name( 0, $pkClassLookup->{name}, $fkClassLookup->{name} );
  }

  # Classify the multiplicity (if given) of the ends of the association

  my $pkMult =
    $self->{utils}->classify_multiplicity( $pkEnd->{'multiplicity'} );
  my $fkMult =
    $self->{utils}->classify_multiplicity( $fkEnd->{'multiplicity'} );

  # By default, foreign keys are constrained to be 'not null'
  my $defFKnull = 'not null';

  # Work out the constraint action for the foreign key
  my $constraintAction = '';
  if ( $self->{uml} ) {

    # UML interpretation

    # Only one of the left and right end aggregation can be
    # non-zero; 1 = aggregation, 2 = composition.
    my $aggregation = $pkEnd->{'aggregate'} + $fkEnd->{'aggregate'};
    if ( $aggregation == 0 ) {    # No semantics specified
      $constraintAction = '';
    }
    elsif ( $aggregation == 1 ) {    # Aggregation
      $constraintAction = 'on delete set NULL';
      $defFKnull        = 'null';
    }
    elsif ( $aggregation == 2 ) {    # Composition
      $constraintAction = 'on delete cascade';
    }
  }
  else {

    # ERD interpretation

    # If Utils::classify_multiplicity didn't understand the multiplicity
    # field, then assume it's a constraint action, and set the
    # multiplicity classification to 'none'

    if ( $fkMult eq 'undef' ) {
      $constraintAction = $fkEnd->{'multiplicity'};
      $fkMult           = 'none';
    }

    # If the constraint action is 'on delete set null', then
    # allow the FK to have null value

    if ( $constraintAction =~ /on\s+delete\s+set\s+null/i ) {
      $defFKnull = 'null';
    }

    # tedia2sql v1.2.9b usage of 'on delete clause'
    # The 'on cascade delete' clauses were on opposite ends of
    # the association for one-to-many and one-to-one for ERD mode!
    #       if ($arity eq 'zmany' && $fkMult eq 'undef') {
    #           $constraintAction = $fkEnd->{'multiplicity'};
    #           $fkMult = 'none';
    #       } elsif ($arity eq 'zone' && $pkMult eq 'undef') {
    #           $constraintAction = $pkEnd->{'multiplicity'};
    #           $pkMult = 'none';
    #       }
  }

  # If the arity implied by the association is one-to-many, set the
  # arity classifications appropriately if they weren't given

  if ( $arity eq 'zmany' ) {
    $pkMult = 'one'   if ( $pkMult eq 'none' );
    $fkMult = 'zmany' if ( $fkMult eq 'none' );
    if (
         $pkMult ne 'one'
      || $self->{uml}
      ? $fkMult !~ /^z?(many|one)$/
      : $fkMult !~ /^z?many$/
      )
    {
      $self->{log}->warn( "Inappropriate multiplicity ($pkMult->$fkMult)"
        . " specified in $assocName");
      return 0;
    }
  }
  elsif ( $arity eq 'zone' ) {
    $pkMult = 'one'  if ( $pkMult eq 'none' );
    $fkMult = 'zone' if ( $fkMult eq 'none' );
    if ( $pkMult ne 'one'
      || $fkMult !~ /^z?one$/ )
    {
      $self->{log}->warn( "Inappropriate multiplicity ($pkMult->$fkMult)"
        . " specified in $assocName");
      return 0;
    }
  }

  $defFKnull = 'null' if ( $pkMult =~ /^z(many|one)$/ );

  # Generate names if they haven't been specified
  my $pkEndKey = $pkEnd->{'role'};
  my $fkEndKey = $fkEnd->{'role'};
  my $pkPK     = $pkClassLookup->{pk};        # List of primary key attributes
  my $pkUIn    = $pkClassLookup->{uindxn};    # List of unique index descriptors
  my $pkUIc    = $pkClassLookup->{uindxc};    # List of unique index descriptors
  my $pkAtts   = undef;
  my $fkAtts   = undef;

  if ($pkEndKey) {

    # Use user-supplied names for the primary key if given

    if ( $pkClassLookup->{type} eq 'table' ) {
      $pkEndKey =~ s/\s//g;
      my $pkNames = $self->{utils}->names_from_attlist($pkPK);
      if ( $self->{utils}->name_case($pkNames) eq
        $self->{utils}->name_case($pkEndKey) )