view release on metacpan or  search on metacpan

DBSchema.pm  view on Meta::CPAN

  my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) );

  my @r = ();
  my @later = ();

  foreach my $table ( $new->tables ) {
  
    if ( $self->table($table) ) {
  
      warn "$table exists\n" if $DEBUG > 1;

      push @r,
        $self->table($table)->sql_alter_table( $new->table($table),
                                                 $dbh, $opt );
      push @later,
        $self->table($table)->sql_alter_constraints( $new->table($table),
                                                       $dbh, $opt );

    } else {
  
      warn "table $table does not exist.\n" if $DEBUG;

      push @r,     $new->table($table)->sql_create_table(    $dbh );
      push @later, $new->table($table)->sql_add_constraints( $dbh );
  
    }
  
  }

  if ( $opt->{'drop_tables'} ) {

    warn "drop_tables enabled\n" if $DEBUG;

    # drop tables not in $new
    foreach my $table ( grep !$new->table($_), $self->tables ) {

      warn "table $table should be dropped.\n" if $DEBUG;

      push @r, $self->table($table)->sql_drop_table( $dbh );

    }

  }

  push @r, @later;

  warn join("\n", @r). "\n"
    if $DEBUG > 1;

  @r;
  
}

=item update_schema [ OPTIONS_HASHREF, ] PROTOTYPE_SCHEMA, DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ]

Same as sql_update_schema, except actually runs the SQL commands to update
the schema.  Throws a fatal error if any statement fails.

=cut

sub update_schema {
  #my($self, $new, $dbh) = ( shift, shift, _dbh(@_) );
  my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) );

  foreach my $statement ( $self->sql_update_schema( $opt, $new, $dbh ) ) {
    $dbh->do( $statement )
      or die "Error: ". $dbh->errstr. "\n executing: $statement";
  }

}

=item pretty_print

Returns the data in this schema as Perl source, suitable for assigning to a
hash.

=cut

sub pretty_print {
  my($self) = @_;

  join("},\n\n",
    map {
      my $tablename = $_;
      my $table = $self->table($tablename);
      my %indices = $table->indices;

      "'$tablename' => {\n".
        "  'columns' => [\n".
          join("", map { 
                         #cant because -w complains about , in qw()
                         # (also biiiig problems with empty lengths)
                         #"    qw( $_ ".
                         #$table->column($_)->type. " ".
                         #( $table->column($_)->null ? 'NULL' : 0 ). " ".
                         #$table->column($_)->length. " ),\n"
                         "    '$_', ".
                         "'". $table->column($_)->type. "', ".
                         "'". $table->column($_)->null. "', ". 
                         "'". $table->column($_)->length. "', ".

                         ( ref($table->column($_)->default)
                             ? "\\'". ${ $table->column($_)->default }. "'"
                             : "'". $table->column($_)->default. "'"
                         ).', '.

                         "'". $table->column($_)->local. "',\n"
                       } $table->columns
          ).
        "  ],\n".
        "  'primary_key' => '". $table->primary_key. "',\n".

        #old style index representation..

        ( 
          $table->{'unique'} # $table->_unique
            ? "  'unique' => [ ". join(', ',
                map { "[ '". join("', '", @{$_}). "' ]" }
                    @{$table->_unique->lol_ref}
              ).  " ],\n"
            : ''