DBIx::SchemaChecksum - Generate and compare checksums of database schematas

    my $sc = DBIx::SchemaChecksum->new( dsn => 'dbi:Pg:name=foo' );
    print $sc->checksum;

    my $checksum = $sc->checksum;

    my $schemadump = $self->schemadump;

    $self->apply_sql_snippets( $starting_checksum );

    my $update_info = $self->build_update_path( '/path/to/sql/snippets' )

    my ($pre, $post) = $self->get_checksums_from_snippet( $file );

  -- preSHA1sum: 89049e457886a86886a4fdf1f905b69250a8236c
  -- postSHA1sum: d9a02517255045167053ea92dace728e1389f8ca

  alter table foo add column bar;

    perldoc DBIx::SchemaChecksum

package DBIx::SchemaChecksum;

use 5.010;
use Moose;
use version; our $VERSION = version->new('0.25');

use DBI;
use Digest::SHA1;
use Data::Dumper;
use Path::Class;
use Carp;
use File::Find::Rule;

with 'MooseX::Getopt';

has 'dsn'      => ( isa => 'Str', is => 'ro' );
has 'user'     => ( isa => 'Str', is => 'ro' );
has 'password' => ( isa => 'Str', is => 'ro' );

# for strange reasons, MooseX::Getop does not work with DBI::db
# constraint
#has 'dbh'      => ( isa => 'DBI::db', is  => 'rw' );
has 'dbh' => ( is => 'rw' );

has 'catalog' => ( is => 'ro', isa => 'Str', default => '%' );
has 'schemata' =>
    ( is => 'ro', isa => 'ArrayRef[Str]', default => sub { ['%'] } );
has 'tabletype' => ( is => 'ro', isa => 'Str', default => 'table' );

has 'sqlsnippetdir' => ( isa => 'Str', is => 'ro' );

# mainly needed for scripts
has 'verbose'      => ( is => 'rw', isa => 'Bool', default => 0 );
has 'no_prompt'    => ( is => 'rw', isa => 'Bool', default => 0 );
has 'dry_run'      => ( is => 'rw', isa => 'Bool', default => 0 );
has 'ignore_order' => ( is => 'rw', isa => 'Bool', default => 0 );
has 'show_update_path'  => ( is => 'rw', isa => 'Bool', default => 0 );

# internal

has '_schemadump'  => ( is => 'rw', isa => 'Str' );
has '_update_path' => ( is => 'rw', isa => 'HashRef' );

sub BUILD {
    my $self = shift;

    confess "Attribute (dsn) or (dbh) is required"
        unless $self->dsn || $self->dbh;

    unless ( defined $self->dbh() ) {
        my $dbh = DBI->connect( $self->dsn, $self->user, $self->password,
            { RaiseError => 1 } );

        $self->dbh($dbh);
    }

}

sub checksum {
    my $self = shift;

    my $as_string = $self->schemadump;
    return Digest::SHA1::sha1_hex($as_string);
}

sub schemadump {
    my $self = shift;

    return $self->_schemadump if $self->_schemadump;

    my $tabletype = $self->tabletype;
    my $catalog   = $self->catalog;

    my $dbh = $self->dbh;

    my @metadata = qw(COLUMN_NAME COLUMN_SIZE NULLABLE TYPE_NAME COLUMN_DEF);
    push( @metadata, 'ORDINAL_POSITION' ) unless $self->ignore_order;

    my %relevants = ();
    foreach my $schema ( @{ $self->schemata } ) {
        foreach
            my $table ( $dbh->tables( $catalog, $schema, '%', $tabletype ) )
        {
            my %data = ( table => $table );

            # remove schema name from table
            my $t = $table;
            $t =~ s/^.*?\.//;

            my @pks = $dbh->primary_key( $catalog, $schema, $t );
            $data{primary_keys} = \@pks if @pks;

            # columns
            my $sth_col = $dbh->column_info( $catalog, $schema, $t, '%' );

            my $column_info = $sth_col->fetchall_hashref('COLUMN_NAME');

            while ( my ( $column, $data ) = each %$column_info ) {
                $data{columns}{$column}
                    = { map { $_ => $data->{$_} } @metadata };
                # add postgres enums
                if ( $data->{pg_enum_values} ) {
                    $data{columns}{$column}{pg_enum_values}
                        = $data->{pg_enum_values};
                }
            }

            # foreign keys
            my $sth_fk
                = $dbh->foreign_key_info( '', '', '', $catalog, $schema, $t );
            if ($sth_fk) {
                $data{foreign_keys} = $sth_fk->fetchall_arrayref( {
                        map { $_ => 1 }
                            qw(FK_NAME UK_NAME UK_COLUMN_NAME FK_TABLE_NAME FK_COLUMN_NAME UPDATE_RULE DELETE_RULE DEFERRABILITY)
                    }
                );
            }

            # postgres unique constraints
            # very crude hack to see if we're running postgres
            if ( $INC{'DBD/Pg.pm'} ) {
                my @unique;
                my $sth=$dbh->prepare( "select indexdef from pg_indexes where schemaname=? and tablename=?");
                $sth->execute($schema, $t);
                while (my ($index) =$sth->fetchrow_array) {
                    $index=~s/$schema\.//g;
                    push(@unique,$index);
                }
                $data{unique_keys} = \@unique if @unique;
            }

            # postgres cleanup
            foreach my $col ( values %{ $data{columns} } ) {
                #  strip schema dependent type definition
                $col->{TYPE_NAME} =~ s/^(?:.+\.)?(.+)$/$1/g;

                # remove types from autoincrement
                if ( $col->{COLUMN_DEF} && $col->{COLUMN_DEF} =~ /nextval/ ) {
                    $col->{COLUMN_DEF} =~ m{'([\w\.\-_]+)'};
                    if ($1) {
                        $col->{COLUMN_DEF} = 'nextval:' . $1;
                    }
                }
            }

            $relevants{$table} = \%data;
        }

    }
    my $dumper = Data::Dumper->new( [ \%relevants ] );
    $dumper->Sortkeys(1);
    return $self->_schemadump( scalar $dumper->Dump );
}

# sqlite column_info monkeypatch
# see http://rt.cpan.org/Public/Bug/Display.html?id=13631
BEGIN {
    *DBD::SQLite::db::column_info = \&_sqlite_column_info;
}

sub _sqlite_column_info {
    my ( $dbh, $catalog, $schema, $table, $column ) = @_;

    $table =~ s/["']//g;
    $column = undef
        if defined $column && $column eq '%';

    my $sth_columns = $dbh->prepare(qq{PRAGMA table_info('$table')});
    $sth_columns->execute;

    my @names = qw( TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME
        DATA_TYPE TYPE_NAME COLUMN_SIZE BUFFER_LENGTH
        DECIMAL_DIGITS NUM_PREC_RADIX NULLABLE
        REMARKS COLUMN_DEF SQL_DATA_TYPE SQL_DATETIME_SUB
        CHAR_OCTET_LENGTH ORDINAL_POSITION IS_NULLABLE
    );

    my @cols;
    while ( my $col_info = $sth_columns->fetchrow_hashref ) {
        next if defined $column && $column ne $col_info->{name};

        my %col;

        $col{TABLE_NAME}  = $table;
        $col{COLUMN_NAME} = $col_info->{name};

        my $type = $col_info->{type};
        if ( $type =~ s/(\w+)\((\d+)(?:,(\d+))?\)/$1/ ) {
            $col{COLUMN_SIZE}    = $2;
            $col{DECIMAL_DIGITS} = $3;
        }

        $col{TYPE_NAME} = $type;

        $col{COLUMN_DEF} = $col_info->{dflt_value}
            if defined $col_info->{dflt_value};

        if ( $col_info->{notnull} ) {
            $col{NULLABLE}    = 0;
            $col{IS_NULLABLE} = 'NO';
        }
        else {
            $col{NULLABLE}    = 1;
            $col{IS_NULLABLE} = 'YES';
        }

        for my $key (@names) {
            $col{$key} = undef
                unless exists $col{$key};
        }

        push @cols, \%col;
    }

    my $sponge = DBI->connect( "DBI:Sponge:", '', '' )
        or
        return $dbh->DBI::set_err( $DBI::err, "DBI::Sponge: $DBI::errstr" );
    my $sth = $sponge->prepare(
        "column_info $table",
        {   rows          => [ map { [ @{$_}{@names} ] } @cols ],
            NUM_OF_FIELDS => scalar @names,
            NAME          => \@names,
        }
    ) or return $dbh->DBI::set_err( $sponge->err(), $sponge->errstr() );
    return $sth;
}

sub apply_sql_snippets {
    my $self          = shift;
    my $this_checksum = shift;
    croak "No current checksum" unless $this_checksum;
    my $update_path = $self->_update_path;

    my $update = $update_path->{$this_checksum}
        if ( exists $update_path->{$this_checksum} );

    unless ($update) {
        die "No update found that's based on $this_checksum.\n";
    }

    if ( $update->[0] eq 'SAME_CHECKSUM' ) {
        return unless $update->[1];
        my ( $file, $expected_post_checksum ) = splice( @$update, 1, 2 );

        $self->apply_file( $file, $expected_post_checksum );
    }
    else {
        $self->apply_file(@$update);
    }
}

sub apply_file {
    my ( $self, $file, $expected_post_checksum ) = @_;
    
    if ($self->show_update_path) {
        print $file->basename." (".$expected_post_checksum.")\n";
        return $self->apply_sql_snippets($expected_post_checksum);
    }

    my $yes = 0;
    if ( $self->no_prompt ) {
        $yes = 1;
        print "Applying " .$file->basename. "\n";
    }
    else {
        my $ask_user = 1;
        while ($ask_user) {
            print "Do you want me to apply <" . $file->basename . ">? [y/n] ";
            my $in = <STDIN>;
            chomp($in);
            if ( $in =~ /^y/i ) {
                $yes      = 1;
                $ask_user = 0;
            }
            elsif ( $in =~ /^n/i ) {
                $yes      = 0;
                $ask_user = 0;
            }
        }
    }

    if ($yes) {
        say("Applying the patch") if $self->verbose;
        my $content = $file->slurp;

        my $dbh = $self->dbh;
        $dbh->begin_work;

        $content =~ s/^\s*--.+$//gm;
        foreach my $command ( split( /(?!:[\\]);/, $content ) ) {
            $command =~ s/\A\s+//;
            $command =~ s/\s+\Z//;

            next unless $command;
            if ( $self->dry_run ) {
                say "dry run!" if $self->verbose;
            }
            else {
                say "Executing: $command" if $self->verbose;
                eval { $dbh->do($command) };
                if ($@) {
                    $dbh->rollback;
                    say "SQL error: $@";
                    say "ABORTING!";
                    exit;
                }
            }
        }

        if ( $self->dry_run ) {
            $dbh->rollback;
            say "dry run, so checksums cannot match. We proceed anyway...";
            return $self->apply_sql_snippets($expected_post_checksum);
        }

        # new checksum
        $self->_schemadump('');
        my $post_checksum = $self->checksum;
        if ( $post_checksum eq $expected_post_checksum ) {
            say "post checksum OK";
            $dbh->commit;
            return $self->apply_sql_snippets($post_checksum);
        }
        else {
            say "post checksum mismatch!";
            say "  expected $expected_post_checksum";
            say "  got      $post_checksum";
            $dbh->rollback;
            say "ABORTING!";
            exit;
        }
    }
    else {
        say "I am not applying this file. So I stop.";
        exit;
    }
}

sub build_update_path {
    my $self = shift;
    my $dir = shift || $self->sqlsnippetdir;
    croak("Please specify sqlsnippetdir") unless $dir;
    croak("Cannot find sqlsnippetdir: $dir") unless -d $dir;

    say "Checking directory $dir for checksum_files" if $self->verbose;

    my %update_info;
    my @files = File::Find::Rule->file->name('*.sql')->in($dir);

    foreach my $file ( sort @files ) {
        my ( $pre, $post ) = $self->get_checksums_from_snippet($file);

        if ( !$pre && !$post ) {
            say "skipping $file (has no checksums)" if $self->verbose;
            next;
        }

        if ( $pre eq $post ) {
            if ( $update_info{$pre} ) {
                my @new = ('SAME_CHECKSUM');
                foreach my $item ( @{ $update_info{$pre} } ) {
                    push( @new, $item ) unless $item eq 'SAME_CHECKSUM';
                }
                $update_info{$pre} = \@new;
            }
            else {
                $update_info{$pre} = ['SAME_CHECKSUM'];
            }
        }

        if (   $update_info{$pre}
            && $update_info{$pre}->[0] eq 'SAME_CHECKSUM' )
        {
            if ( $post eq $pre ) {
                splice( @{ $update_info{$pre} },
                    1, 0, Path::Class::File->new($file), $post );
            }
            else {
                push( @{ $update_info{$pre} },
                    Path::Class::File->new($file), $post );
            }
        }
        else {
            $update_info{$pre} = [ Path::Class::File->new($file), $post ];
        }
    }

    return $self->_update_path( \%update_info ) if %update_info;
    return;
}

sub get_checksums_from_snippet {
    my $self     = shift;
    my $filename = shift;
    croak "Need a filename" unless $filename;

    my %checksums;

    open( my $fh, "<", $filename ) || croak "Cannot read $filename: $!";
    while (<$fh>) {
        if (m/^--\s+(pre|post)SHA1sum:?\s+([0-9A-Fa-f]{40,})\s+$/) {
            $checksums{$1} = $2;
        }
    }
    close $fh;
    return map { $checksums{$_} || '' } qw(pre post);
}

q{ Favourite record of the moment: The Dynamics - Version Excursions }

__END__