view release on metacpan or  search on metacpan

lib/SQL/Translator/Parser/Oracle.pm  view on Meta::CPAN

      unless defined $::RD_ERRORS;    # Make sure the parser dies when it encounters an error
  local $::RD_WARN = 1
      unless defined $::RD_WARN;      # Enable warnings. This will warn on unused rules &c.
  local $::RD_HINT = 1
      unless defined $::RD_HINT;      # Give out hints to help fix problems.

  local $::RD_TRACE = $translator->trace ? 1 : undef;
  local $DEBUG      = $translator->debug;

  my $parser = ddl_parser_instance('Oracle');

  my $result = $parser->startrule($data);
  die "Parse failed.\n" unless defined $result;
  if ($DEBUG) {
    warn "Parser results =\n", Dumper($result), "\n";
  }

  my $schema      = $translator->schema;
  my $indices     = $result->{'indices'};
  my $constraints = $result->{'constraints'};
  my @tables
      = sort { $result->{'tables'}{$a}{'order'} <=> $result->{'tables'}{$b}{'order'} } keys %{ $result->{'tables'} };

  for my $table_name (@tables) {
    my $tdata = $result->{'tables'}{$table_name};
    next unless $tdata->{'table_name'};
    my $table = $schema->add_table(
      name     => $tdata->{'table_name'},
      comments => $tdata->{'comments'},
    ) or die $schema->error;

    $table->options($tdata->{'table_options'});

    my @fields = sort { $tdata->{'fields'}->{$a}->{'order'} <=> $tdata->{'fields'}->{$b}->{'order'} }
        keys %{ $tdata->{'fields'} };

    for my $fname (@fields) {
      my $fdata = $tdata->{'fields'}{$fname};
      my $field = $table->add_field(
        name              => $fdata->{'name'},
        data_type         => $fdata->{'data_type'},
        size              => $fdata->{'size'},
        default_value     => $fdata->{'default'},
        is_auto_increment => $fdata->{'is_auto_inc'},
        is_nullable       => $fdata->{'null'},
        comments          => $fdata->{'comments'},
      ) or die $table->error;
    }

    push @{ $tdata->{'indices'} },     @{ $indices->{$table_name}     || [] };
    push @{ $tdata->{'constraints'} }, @{ $constraints->{$table_name} || [] };

    for my $idata (@{ $tdata->{'indices'} || [] }) {
      my $index = $table->add_index(
        name   => $idata->{'name'},
        type   => uc $idata->{'type'},
        fields => $idata->{'fields'},
      ) or die $table->error;
    }

    for my $cdata (@{ $tdata->{'constraints'} || [] }) {
      my $constraint = $table->add_constraint(
        name             => $cdata->{'name'},
        type             => $cdata->{'type'},
        fields           => $cdata->{'fields'},
        expression       => $cdata->{'expression'},
        reference_table  => $cdata->{'reference_table'},
        reference_fields => $cdata->{'reference_fields'},
        match_type       => $cdata->{'match_type'} || '',
        on_delete        => $cdata->{'on_delete'}  || $cdata->{'on_delete_do'},
        on_update        => $cdata->{'on_update'}  || $cdata->{'on_update_do'},
      ) or die $table->error;
    }
  }

  my @procedures = sort { $result->{procedures}->{$a}->{'order'} <=> $result->{procedures}->{$b}->{'order'} }
      keys %{ $result->{procedures} };
  foreach my $proc_name (@procedures) {
    $schema->add_procedure(
      name  => $proc_name,
      owner => $result->{procedures}->{$proc_name}->{owner},
      sql   => $result->{procedures}->{$proc_name}->{sql},
    );
  }

  my @views
      = sort { $result->{views}->{$a}->{'order'} <=> $result->{views}->{$b}->{'order'} } keys %{ $result->{views} };
  foreach my $view_name (keys %{ $result->{views} }) {
    $schema->add_view(
      name => $view_name,
      sql  => $result->{views}->{$view_name}->{sql},
    );
  }

  my @triggers = sort { $result->{triggers}->{$a}->{'order'} <=> $result->{triggers}->{$b}->{'order'} }
      keys %{ $result->{triggers} };
  foreach my $trigger_name (@triggers) {
    $schema->add_trigger(
      name   => $trigger_name,
      action => $result->{triggers}->{$trigger_name}->{action},
    );
  }

  return 1;
}

1;

# -------------------------------------------------------------------
# Something there is that doesn't love a wall.
# Robert Frost
# -------------------------------------------------------------------

=pod

=head1 AUTHOR

Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.

=head1 SEE ALSO

SQL::Translator, Parse::RecDescent, DDL::Oracle.

=cut