view release on metacpan or  search on metacpan

lib/DBIx/MyDatabaseMunger.pm  view on Meta::CPAN

    # Read the table name from the "CREATE TABLE `<NAME>` (
    shift( @create_sql ) =~ m/CREATE TABLE `(.*)`/
        or die "Create table SQL does not begin with CREATE TABLE!\n";
    my $name = $1;

    # The last line should have the table options
    # ) ENGINE=InnoDB AUTO_INCREMENT=2 DEFAULT CHARSET=utf8 COMMENT='App User'
    # We don't need to understand every last option, but let's extract at least
    # the ENGINE and COMMENT.
    my $line = pop @create_sql;
    my($table_options) = $line =~ m/\)\s*(.*)/;

    # Extract the ENGINE= from the table options.
    $table_options =~ s/ENGINE=(\S+)\s*//
        or die "Table options lack ENGINE specification?!";
    my $engine = $1;

    # Drop data about AUTO_INCREMENT
    $table_options =~ s/AUTO_INCREMENT=(\d+)\s*//;

    # Extract the COMMENT and undo mysql ' quoting. We shouldn't have to deal
    # with weird characters or backslashes in comments, so let's keep it
    # simple.
    my $comment;
    if( $table_options =~ s/\s*COMMENT='(([^']|'')*)'// ) {
        $comment = $1;
        $comment =~ s/''/'/g;
    }

    # The remaining lines should be column definitions followed by keys.
    my @columns;
    my %column_definition;
    my @constraints;
    my %constraint_definition;
    my @keys;
    my %key_definition;
    my @primary_key;

    for my $line ( @create_sql ) {
        $line =~ s/,$//; # Strip trailing commas

        # Strip out DEFAULT NULL so that it is easier to compare column
        # definitions.
        $line =~ s/ DEFAULT NULL//;

        if( $line =~ m/^\s*`([^`]+)`\s*(.*)/ ) {
            my($col, $def) = ($1, $2);
            push @columns, $col;
            $column_definition{ $col } = $def;
        } elsif( $line =~ m/^\s*PRIMARY KEY \(`(.*)`\)/ ) {
            @primary_key = split( '`,`', $1 );
        } elsif( $line =~ m/^\s*((UNIQUE )?KEY `([^`]+)`.*)/ ) {
            my($key, $def) = ($3, $1);
            push @keys, $key;
            $key_definition{ $key } = $def;
        } elsif( $line =~ m/^\s*
            CONSTRAINT\s+`(.*)`\s+
            FOREIGN\s+KEY\s+\(`(.*)`\)\s+
            REFERENCES\s+`(.*)`\s+\(`(.*)`\)\s+(.*)
        /x ) {
            my($name, $cols, $reftable, $refcols, $cascade_opt) =
                ($1, $2, $3, $4, $5);
            my @cols = split '`,`', $cols;
            my @refcols = split '`,`', $refcols;
            push @constraints, $name;
            $constraint_definition{ $name } = {
                name => $name,
                columns => \@cols,
                reference_table => $reftable,
                reference_columns => \@refcols,
                cascade_opt => $cascade_opt,
            };
        } else {
            warn "Don't understand line in CREATE TABLE:\n$line";
        }
    }

    return {
        name => $name,
        comment => $comment,
        engine => $engine,
        table_options => $table_options,
        columns => \@columns,
        column_definition => \%column_definition,
        keys => \@keys,
        key_definition => \%key_definition,
        constraints => \@constraints,
        constraint_definition => \%constraint_definition,
        primary_key => \@primary_key,
    };
}

=item $o->read_table_sql ( $table_name )

Given a table name, retrieve the table definition SQL.

=cut

sub read_table_sql : method
{
    my $self = shift;
    my($name) = @_;

    # File slurp mode.
    local $/;

    open my $fh, "$self->{dir}/table/$name.sql";
    my $sql = <$fh>;
    close $fh;

    return $sql;
}

=item $o->get_table_desc ( $table_name )

Given a table name, retrieve the parsed table definition.

=cut

sub get_table_desc : method
{
    my $self = shift;
    my($name) = @_;

    my $sql = $self->read_table_sql( $name );
    my $desc;
    eval {
        $desc = $self->parse_create_table_sql( $sql );
    };
    die "Error parsing SQL for table `$name`:\n$@" if $@;
    die "Table name mismatch while reading SQL for `$name`, " .

lib/DBIx/MyDatabaseMunger.pm  view on Meta::CPAN

        $self->create_table_sql( $table, { no_constraints => 1 } ),
    );

    for my $constraint ( @{$table->{constraints}} ) {
        $self->queue_add_table_constraint($table, $constraint);
    }
}

=item $o->create_table_sql ( $table )

=cut

sub create_table_sql : method
{
    my $self = shift;
    my( $table, $opt ) = @_;

    my $sql = "CREATE TABLE `$table->{name}` (\n";

    for my $col ( @{ $table->{columns} } ) {
        $sql .= "  `$col` $table->{column_definition}{$col},\n";
    }

    for my $key ( sort @{ $table->{keys} } ) {
        $sql .= "  $table->{key_definition}{$key},\n";
    }

    unless( $opt->{no_constraints} ) {
        for my $constraint ( sort @{$table->{constraints}} ) {
            $sql .= "  " . $self->constraint_sql(
                $table->{constraint_definition}{$constraint}
            ) . ",\n";
        }
    }

    $sql .= "  PRIMARY KEY (`" . join('`,`', @{$table->{primary_key}}) . "`)\n";
    $sql .= ") ENGINE=$table->{engine} $table->{table_options}";
    if( $table->{comment} ) {
        my $comment = $table->{comment};
        $comment =~ s/'/''/g;
        $sql .= " COMMENT='$comment'";
    }
    $sql .= "\n";

    return $sql;
}

=item $o->constraint_sql ( $constraint )

=cut

sub constraint_sql : method
{
    my $self = shift;
    my($constraint) = @_;
    return "CONSTRAINT `$constraint->{name}` FOREIGN KEY (`"
        . join('`,`', @{$constraint->{columns}})
        . "`) REFERENCES `$constraint->{reference_table}` (`"
        . join('`,`', @{$constraint->{reference_columns}})
        . "`)" . (
            $constraint->{cascade_opt} ? " $constraint->{cascade_opt}" : ''
        );
}

=item $o->queue_add_table_constraint ( $table, $constraint )

=cut

sub queue_add_table_constraint : method
{
    my $self = shift;
    my($table, $constraint) = @_;

    my $def = $table->{constraint_definition}{$constraint};

    $self->__queue_sql( 'add_constraint',
        "Add constraint $constraint on $table->{name}.",
        "ALTER TABLE `$table->{name}` ADD ".$self->constraint_sql( $def ),
    );

    return $self;
}

=item $o->queue_drop_table_constraint ( $table, $constraint )

=cut

sub queue_drop_table_constraint : method
{
    my $self = shift;
    my($table, $constraint) = @_;

    $self->__queue_sql( 'drop_constraint',
        "Drop constraint $constraint on $table->{name}.",
        "ALTER TABLE `$table->{name}` DROP FOREIGN KEY `$constraint`",
    );

    return $self;
}

=item $o->queue_table_updates( $current, $desired )

=cut

sub queue_table_updates : method
{
    my $self = shift;
    my($current, $new) = @_;

    for( my $i=0; $i < @{ $new->{columns} }; ++$i ) {
        my $col = $new->{columns}[$i];
        if( $current->{column_definition}{$col} ) {
            unless( $current->{column_definition}{$col}
                 eq $new->{column_definition}{$col}
            ) {
                $self->__queue_sql( 'modify_column',
                    "Modify column $col in $current->{name}\n",
                    "ALTER TABLE `$current->{name}` " . 
                    "MODIFY COLUMN `$col` $new->{column_definition}{$col}",
                );
            }