view release on metacpan or  search on metacpan

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

    # do nothing; is there a better way to write this? -- ky
  }

  my $result = $parser->startrule($data);
  return $translator->error("Parse failed.") unless defined $result;
  warn "Parse result:" . Dumper($result) if $DEBUG;

  my $schema = $translator->schema;
  $schema->name($result->{'database_name'}) if $result->{'database_name'};

  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};
    my $table = $schema->add_table(name => $tdata->{'table_name'},)
        or die $schema->error;

    $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};
      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;

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

      for my $qual (qw[ binary unsigned zerofill list collate ], 'character set', 'on update') {
        if (my $val = $fdata->{$qual} || $fdata->{ uc $qual }) {
          next if ref $val eq 'ARRAY' && !@$val;
          $field->extra($qual, $val);
        }
      }

      if ($fdata->{'has_index'}) {
        $table->add_index(
          name   => '',
          type   => 'NORMAL',
          fields => $fdata->{'name'},
        ) or die $table->error;
      }

      if ($fdata->{'is_unique'}) {
        $table->add_constraint(
          name   => '',
          type   => 'UNIQUE',
          fields => $fdata->{'name'},
        ) or die $table->error;
      }

      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 $index = $table->add_index(
        name   => $idata->{'name'},
        type   => uc $idata->{'type'},
        fields => $idata->{'fields'},
      ) or die $table->error;
    }

    if (my @options = @{ $tdata->{'table_options'} || [] }) {
      my @cleaned_options;
      my @ignore_opts
          = $translator->parser_args->{'ignore_opts'}
          ? split(/,/, $translator->parser_args->{'ignore_opts'})
          : ();
      if (@ignore_opts) {
        my $ignores = { map { $_ => 1 } @ignore_opts };
        foreach my $option (@options) {

          # make sure the option isn't in ignore list
          my ($option_key) = keys %$option;
          if (!exists $ignores->{$option_key}) {
            push @cleaned_options, $option;
          }
        }
      } else {
        @cleaned_options = @options;
      }
      $table->options(\@cleaned_options) 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;
    }

    # After the constrains and PK/idxs have been created,
    # we normalize fields
    normalize_field($_) for $table->get_fields;
  }

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

  for 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} };

  for my $view_name (@views) {
    my $view = $result->{'views'}{$view_name};
    my @flds = map { $_->{'alias'} || $_->{'name'} } @{ $view->{'select'}{'columns'} || [] };
    my @from = map { $_->{'alias'} || $_->{'name'} } @{ $view->{'from'}{'tables'}    || [] };

    $schema->add_view(
      name    => $view_name,
      sql     => $view->{'sql'},
      order   => $view->{'order'},
      fields  => \@flds,
      tables  => \@from,
      options => $view->{'options'}
    );
  }

  return 1;
}

# Takes a field, and returns
sub normalize_field {
  my ($field) = @_;
  my ($size, $type, $list, $unsigned, $changed);

  $size     = $field->size;
  $type     = $field->data_type;
  $list     = $field->extra->{list} || [];
  $unsigned = defined($field->extra->{unsigned});

  if (!ref $size && $size eq 0) {
    if (lc $type eq 'tinyint') {
      $changed = $size != 4 - $unsigned;
      $size    = 4 - $unsigned;
    } elsif (lc $type eq 'smallint') {
      $changed = $size != 6 - $unsigned;
      $size    = 6 - $unsigned;
    } elsif (lc $type eq 'mediumint') {
      $changed = $size != 9 - $unsigned;
      $size    = 9 - $unsigned;