view release on metacpan or  search on metacpan

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

    | DOLLARSTRING
    | /null/i
    { 'NULL' }

END_OF_GRAMMAR

sub parse {
  my ($translator, $data) = @_;

  # Enable warnings within the Parse::RecDescent module.
  local $::RD_ERRORS = 1
      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('PostgreSQL');

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

  my $schema = $translator->schema;
  my @tables = sort { ($result->{tables}{$a}{'order'} || 0) <=> ($result->{tables}{$b}{'order'} || 0) }
      keys %{ $result->{tables} };

  for my $table_name (@tables) {
    my $tdata = $result->{tables}{$table_name};
    my $table = $schema->add_table(

      #schema => $tdata->{'schema_name'},
      name => $tdata->{'table_name'},
    ) or die "Couldn't create table '$table_name': " . $schema->error;

    $table->extra(temporary => 1) if $tdata->{'temporary'};

    $table->comments($tdata->{'comments'});

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

    for my $fname (@fields) {
      my $fdata = $tdata->{'fields'}{$fname};
      next if $fdata->{'drop'};
      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_increment'},
        is_nullable       => $fdata->{'is_nullable'},
        comments          => $fdata->{'comments'},
      ) or die $table->error;

      $table->primary_key($field->name) if $fdata->{'is_primary_key'};

      for my $cdata (@{ $fdata->{'constraints'} }) {
        next unless $cdata->{'type'} eq 'foreign_key';
        $cdata->{'fields'} ||= [ $field->name ];
        push @{ $tdata->{'constraints'} }, $cdata;
      }
    }

    for my $idata (@{ $tdata->{'indices'} || [] }) {
      my @options = ();
      push @options, { using   => $idata->{'method'} } if $idata->{method};
      push @options, { where   => $idata->{'where'} }  if $idata->{where};
      push @options, { include => $idata->{'include'} }
          if $idata->{include};
      my $index = $table->add_index(
        name    => $idata->{'name'},
        type    => uc $idata->{'type'},
        fields  => $idata->{'fields'},
        options => \@options
      ) or die $table->error . ' ' . $table->name;
    }

    for my $cdata (@{ $tdata->{'constraints'} || [] }) {
      my $options = [

        # load this up with the extras
        map +{ %$cdata{$_} }, grep $cdata->{$_},
        qw/include using where/
      ];
      my $constraint = $table->add_constraint(
        name             => $cdata->{'name'},
        type             => $cdata->{'type'},
        fields           => $cdata->{'fields'},
        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'},
        expression       => $cdata->{'expression'},
        options          => $options
          )
          or die "Can't add constraint of type '"
          . $cdata->{'type'}
          . "' to table '"
          . $table->name . "': "
          . $table->error;
    }
  }

  for my $vinfo (@{ $result->{views} }) {
    my $sql = $vinfo->{sql};
    $sql =~ s/\A\s+|\s+\z//g;
    my $view = $schema->add_view(
      name   => $vinfo->{view_name},
      sql    => $sql,
      fields => $vinfo->{fields},
    );

    $view->extra(temporary => 1) if $vinfo->{is_temporary};
  }

  for my $trigger (@{ $result->{triggers} }) {
    $schema->add_trigger(%$trigger);
  }

  return 1;
}

1;

# -------------------------------------------------------------------
# Rescue the drowning and tie your shoestrings.
# Henry David Thoreau
# -------------------------------------------------------------------

=pod

=head1 AUTHORS

Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
Allen Day E<lt>allenday@ucla.eduE<gt>.

=head1 SEE ALSO

perl(1), Parse::RecDescent.

=cut