File Coverage: lib/DBIx/SchemaChecksum.pm

# File Coverage

File: | lib/DBIx/SchemaChecksum.pm
Coverage: | 73.4%

line | stmt | bran | cond | sub | time | code
--- | --- | --- | --- | --- | --- | ---
1 |  |  |  |  |  | package DBIx::SchemaChecksum;
2 |
3 | 12 12 12 |  |  | 12 | 502833 30 343 | use 5.010;
4 | 12 12 12 |  |  | 12 | 2315 5155350 194 | use Moose;
5 | 12 12 12 |  |  | 12 | 123627 5224 157 | use version; our $VERSION = version->new('0.28');
6 |
7 | 12 12 12 |  |  | 12 | 8670 76186 512 | use DBI;
8 | 12 12 12 |  |  | 12 | 2558 3985 332 | use Digest::SHA1;
9 | 12 12 12 |  |  | 12 | 3015 36595 456 | use Data::Dumper;
10 | 12 12 12 |  |  | 12 | 1433 148846 389 | use Path::Class;
11 | 12 12 12 |  |  | 12 | 38 11 363 | use Carp;
12 | 12 12 12 |  |  | 12 | 2520 74927 172 | use File::Find::Rule;
13 |  |  |  |  |  | with 'MooseX::Getopt';
14 |
15 |  |  |  |  |  | has 'dbh' => ( is => 'ro', required=>1 );
16 |
17 |  |  |  |  |  | has 'catalog' => (
18 |  |  |  |  |  | is => 'ro',
19 |  |  |  |  |  | isa => 'Str',
20 |  |  |  |  |  | default => '%',
21 |  |  |  |  |  | documentation => q[might be required by some DBI drivers]
22 |  |  |  |  |  | );
23 |
24 |  |  |  |  |  | has 'schemata' => (
25 |  |  |  |  |  | is => 'ro',
26 |  |  |  |  |  | isa => 'ArrayRef[Str]',
27 |  |  |  |  |  | default => sub { ['%'] },
28 |  |  |  |  |  | documentation => q[List of schematas to include in checksum]
29 |  |  |  |  |  | );
30 |
31 |  |  |  |  |  | has 'tabletype' => (
32 |  |  |  |  |  | is => 'ro',
33 |  |  |  |  |  | isa => 'Str',
34 |  |  |  |  |  | default => 'table',
35 |  |  |  |  |  | documentation => q[Table type according to DBI->table_info]
36 |  |  |  |  |  | );
37 |
38 |  |  |  |  |  | has 'sqlsnippetdir' => (
39 |  |  |  |  |  | isa => 'Str',
40 |  |  |  |  |  | is => 'ro',
41 |  |  |  |  |  | documentation => q[Directory containing sql update files],
42 |  |  |  |  |  | );
43 |
44 |  |  |  |  |  | # mainly needed for scripts
45 |  |  |  |  |  | has 'verbose' => ( is => 'rw', isa => 'Bool', default => 0 );
46 |  |  |  |  |  | has 'dry_run' => ( is => 'rw', isa => 'Bool', default => 0 );
47 |
48 |  |  |  |  |  | # internal
49 |  |  |  |  |  | has '_update_path' => ( is => 'rw', isa => 'HashRef', lazy_build=>1 );
50 |  |  |  |  |  | has '_schemadump' => (
51 |  |  |  |  |  | isa=>'Str',
52 |  |  |  |  |  | is=>'rw',
53 |  |  |  |  |  | lazy_build=>1,
54 |  |  |  |  |  | clearer=>'reset_checksum',
55 |  |  |  |  |  | );
56 |
57 - 110 |  |
    =head1 NAME

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

    =head1 SYNOPSIS

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

    =head1 DESCRIPTION

    When you're dealing with several instances of the same database (eg.
    developer, testing, stage, production), it is crucial to make sure
    that all databases use the same schema. This can be quite an
    hair-pulling experience, and this module should help you keep your
    hair (if you're already bald, it won't make your hair grow back,
    sorry...)

    DBIx::SchemaChecksum connects to your database, gets schema
    information (tables, columns, primary keys, foreign keys) and
    generates a SHA1 digest. This digest can then be used to easily verify schema consistency across different databases.

    B<Caveat:> The same schema might produce different checksums on
    different database versions.

    DBIx::SchemaChecksum works with PostgreSQL 8.3 and SQLite (but see
    below). I assume that thanks to the abstraction provided by the C<DBI>
    it works with most databases. If you try DBIx::SchemaChecksum with
    different database systems, I'd love to hear some feedback...

    =head2 SQLite and column_info

    DBD::SQLite doesn't really implement C<column_info>, which is needed
    to generate the checksum. We use the monkey-patch included in
    http://rt.cpan.org/Public/Bug/Display.html?id=13631
    to make it work

    =head2 Scripts

    Please take a look at the scripts included in this distribution:

    =head3 schema_checksum.pl

    Calculates the checksum and prints it to STDOUT

    =head3 schema_update.pl

    Updates a schema based on the current checksum and SQL snippet files

    =head1 METHODS

    =head2 Public Methods

    =cut
111 |
112 |  |  |  |  |  | sub checksum {
113 | 22 |  |  | 22 | 18004 | my $self = shift;
114 | 22 |  |  |  | 598 | return Digest::SHA1::sha1_hex($self->_schemadump);
115 |  |  |  |  |  | }
116 |
117 - 124 |  |
    =head3 schemadump

        my $schemadump = $self->schemadump;

    Returns a string representation of the whole schema (as a Data::Dumper
    Dump).

    =cut
125 |
126 |  |  |  |  |  | sub _build__schemadump {
127 | 13 |  |  | 13 | 20 | my $self = shift;
128 |
129 | 13 |  |  |  | 351 | my $tabletype = $self->tabletype;
130 | 13 |  |  |  | 351 | my $catalog = $self->catalog;
131 |
132 | 13 |  |  |  | 335 | my $dbh = $self->dbh;
133 |
134 | 13 |  |  |  | 43 | my @metadata = qw(COLUMN_NAME COLUMN_SIZE NULLABLE TYPE_NAME COLUMN_DEF);
135 |
136 | 13 |  |  |  | 25 | my %relevants = ();
137 | 13 13 |  |  |  | 12 362 | foreach my $schema ( @{ $self->schemata } ) {
138 | 13 |  |  |  | 246 | foreach
139 |  |  |  |  |  | my $table ( $dbh->tables( $catalog, $schema, '%', $tabletype ) )
140 |  |  |  |  |  | {
141 | 33 |  |  |  | 9287 | $table=~s/"//g;
142 | 33 |  |  |  | 30 | my %data;
143 |
144 |  |  |  |  |  | # remove schema name from table
145 | 33 |  |  |  | 37 | my $t = $table;
146 | 33 |  |  |  | 84 | $t =~ s/^.*?\.//;
147 |
148 | 33 |  |  |  | 555 | my @pks = $dbh->primary_key( $catalog, $schema, $t );
149 | 33 | 50 |  |  | 33967 | $data{primary_keys} = \@pks if @pks;
150 |
151 |  |  |  |  |  | # columns
152 | 33 |  |  |  | 564 | my $sth_col = $dbh->column_info( $catalog, $schema, $t, '%' );
153 |
154 | 33 |  |  |  | 25350 | my $column_info = $sth_col->fetchall_hashref('COLUMN_NAME');
155 |
156 | 33 |  |  |  | 7210 | while ( my ( $column, $data ) = each %$column_info ) {
157 | 75 375 |  |  |  | 63 454 | my $info = { map { $_ => $data->{$_} } @metadata };
158 |
159 |  |  |  |  |  | # add postgres enums
160 | 75 | 50 |  |  | 128 | if ( $data->{pg_enum_values} ) {
161 | 0 |  |  |  | 0 | $info->{pg_enum_values} = $data->{pg_enum_values};
162 |  |  |  |  |  | }
163 |
164 |  |  |  |  |  | # some cleanup
165 | 75 | 50 |  |  | 93 | if (my $default = $info->{COLUMN_DEF}) {
166 | 0 | 0 |  |  | 0 | if ( $default =~ /nextval/ ) {
167 | 0 |  |  |  | 0 | $default =~ m{'([\w\.\-_]+)'};
168 | 0 | 0 |  |  | 0 | if ($1) {
169 | 0 |  |  |  | 0 | my $new = $1;
170 | 0 |  |  |  | 0 | $new =~ s/^\w+\.//;
171 | 0 |  |  |  | 0 | $default = 'nextval:' . $new;
172 |  |  |  |  |  | }
173 |  |  |  |  |  | }
174 | 0 |  |  |  | 0 | $default=~s/["'\(\)\[\]\{\}]//g;
175 | 0 |  |  |  | 0 | $info->{COLUMN_DEF}=$default;
176 |  |  |  |  |  | }
177 |
178 | 75 |  |  |  | 234 | $info->{TYPE_NAME} =~ s/^(?:.+\.)?(.+)$/$1/g;
179 |
180 | 75 |  |  |  | 221 | $data{columns}{$column} = $info;
181 |  |  |  |  |  | }
182 |
183 |  |  |  |  |  | # foreign keys
184 | 33 |  |  |  | 129 | my $sth_fk
185 |  |  |  |  |  | = $dbh->foreign_key_info( '', '', '', $catalog, $schema, $t );
186 | 33 | 50 |  |  | 51 | if ($sth_fk) {
187 | 0 |  |  |  | 0 | $data{foreign_keys} = $sth_fk->fetchall_arrayref( {
188 | 0 |  |  |  | 0 | map { $_ => 1 }
189 |  |  |  |  |  | qw(FK_NAME UK_NAME UK_COLUMN_NAME FK_TABLE_NAME FK_COLUMN_NAME UPDATE_RULE DELETE_RULE)
190 |  |  |  |  |  | }
191 |  |  |  |  |  | );
192 |  |  |  |  |  | # Nasty workaround
193 | 0 0 |  |  |  | 0 0 | foreach my $row (@{$data{foreign_keys}}) {
194 | 0 |  |  |  | 0 | $row->{DEFERRABILITY} = undef;
195 |  |  |  |  |  | }
196 |  |  |  |  |  | }
197 |
198 |  |  |  |  |  | # postgres unique constraints
199 |  |  |  |  |  | # very crude hack to see if we're running postgres
200 | 33 | 50 |  |  | 92 | if ( $INC{'DBD/Pg.pm'} ) {
201 | 0 |  |  |  | 0 | my @unique;
202 | 0 |  |  |  | 0 | my $sth=$dbh->prepare( "select indexdef from pg_indexes where schemaname=? and tablename=?");
203 | 0 |  |  |  | 0 | $sth->execute($schema, $t);
204 | 0 |  |  |  | 0 | while (my ($index) =$sth->fetchrow_array) {
205 | 0 |  |  |  | 0 | $index=~s/$schema\.//g;
206 | 0 |  |  |  | 0 | push(@unique,$index);
207 |  |  |  |  |  | }
208 | 0 |  |  |  | 0 | @unique = sort (@unique);
209 | 0 | 0 |  |  | 0 | $data{unique_keys} = \@unique if @unique;
210 |  |  |  |  |  | }
211 |
212 | 33 |  |  |  | 915 | $relevants{$table} = \%data;
213 |  |  |  |  |  | }
214 |
215 |  |  |  |  |  | }
216 | 13 |  |  |  | 252 | my $dumper = Data::Dumper->new( [ \%relevants ] );
217 | 13 |  |  |  | 597 | $dumper->Sortkeys(1);
218 | 13 |  |  |  | 311 | $dumper->Indent(1);
219 | 13 |  |  |  | 344 | my $dump = $dumper->Dump;
220 | 13 |  |  |  | 2159 | return $dump;
221 |  |  |  |  |  | }
222 |
223 - 233 |  |
    =head3 build_update_path

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

    Builds the datastructure needed by L<apply_sql_update>.
    C<build_update_path> reads in all files ending in ".sql" in the
    directory passed in (or defaulting to C<< $self->sqlsnippetdir >>). It
    builds something like a linked list of files, which are chained by
    their C<preSHA1sum> and C<postSHA1sum>.

    =cut
234 |
235 |  |  |  |  |  | sub _build__update_path {
236 | 9 |  |  | 9 | 12 | my $self = shift;
237 | 9 |  |  |  | 196 | my $dir = $self->sqlsnippetdir;
238 | 9 | 50 |  |  | 18 | croak("Please specify sqlsnippetdir") unless $dir;
239 | 9 | 100 |  |  | 79 | croak("Cannot find sqlsnippetdir: $dir") unless -d $dir;
240 |
241 | 7 | 50 |  |  | 146 | say "Checking directory $dir for checksum_files" if $self->verbose;
242 |
243 | 7 |  |  |  | 8 | my %update_info;
244 | 7 |  |  |  | 132 | my @files = File::Find::Rule->file->name('*.sql')->in($dir);
245 |
246 | 7 |  |  |  | 5285 | foreach my $file ( sort @files ) {
247 | 18 |  |  |  | 2926 | my ( $pre, $post ) = $self->get_checksums_from_snippet($file);
248 |
249 | 18 | 0 | 33 |  | 24 | if ( !$pre && !$post ) {
250 | 0 | 0 |  |  | 0 | say "skipping $file (has no checksums)" if $self->verbose;
251 | 0 |  |  |  | 0 | next;
252 |  |  |  |  |  | }
253 |
254 | 18 | 100 |  |  | 31 | if ( $pre eq $post ) {
255 | 3 | 50 |  |  | 7 | if ( $update_info{$pre} ) {
256 | 3 |  |  |  | 7 | my @new = ('SAME_CHECKSUM');
257 | 3 3 |  |  |  | 3 7 | foreach my $item ( @{ $update_info{$pre} } ) {
258 | 6 | 50 |  |  | 294 | push( @new, $item ) unless $item eq 'SAME_CHECKSUM';
259 |  |  |  |  |  | }
260 | 3 |  |  |  | 7 | $update_info{$pre} = \@new;
261 |  |  |  |  |  | }
262 |  |  |  |  |  | else {
263 | 0 |  |  |  | 0 | $update_info{$pre} = ['SAME_CHECKSUM'];
264 |  |  |  |  |  | }
265 |  |  |  |  |  | }
266 |
267 | 18 | 100 | 67 |  | 47 | if ( $update_info{$pre}
268 |  |  |  |  |  | && $update_info{$pre}->[0] eq 'SAME_CHECKSUM' )
269 |  |  |  |  |  | {
270 | 3 | 50 |  |  | 6 | if ( $post eq $pre ) {
271 | 3 3 |  |  |  | 4 41 | splice( @{ $update_info{$pre} },
272 |  |  |  |  |  | 1, 0, Path::Class::File->new($file), $post );
273 |  |  |  |  |  | }
274 |  |  |  |  |  | else {
275 | 0 0 |  |  |  | 0 0 | push( @{ $update_info{$pre} },
276 |  |  |  |  |  | Path::Class::File->new($file), $post );
277 |  |  |  |  |  | }
278 |  |  |  |  |  | }
279 |  |  |  |  |  | else {
280 | 15 |  |  |  | 248 | $update_info{$pre} = [ Path::Class::File->new($file), $post ];
281 |  |  |  |  |  | }
282 |  |  |  |  |  | }
283 |
284 | 7 | 100 |  |  | 1234 | return $self->_update_path( \%update_info ) if %update_info;
285 | 1 |  |  |  | 31 | return;
286 |  |  |  |  |  | }
287 |
288 - 301 |  |
    =head3 get_checksums_from_snippet

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

    Returns a list of the preSHA1sum and postSHA1sum for the given file.

    The file has to contain this info in SQL comments, eg:

      -- preSHA1sum: 89049e457886a86886a4fdf1f905b69250a8236c
      -- postSHA1sum: d9a02517255045167053ea92dace728e1389f8ca

      alter table foo add column bar;

    =cut
302 |
303 |  |  |  |  |  | sub get_checksums_from_snippet {
304 | 22 |  |  | 22 | 5904 | my ($self, $filename) = @_;
305 | 22 | 100 |  |  | 48 | die "need a filename" unless $filename;
306 |
307 | 21 |  |  |  | 16 | my %checksums;
308 |
309 | 21 | 100 |  |  | 284 | open( my $fh, "<", $filename ) || croak "Cannot read $filename: $!";
310 | 20 |  |  |  | 186 | while (<$fh>) {
311 | 114 | 100 |  |  | 252 | if (m/^--\s+(pre|post)SHA1sum:?\s+([0-9A-Fa-f]{40,})\s+$/) {
312 | 39 |  |  |  | 114 | $checksums{$1} = $2;
313 |  |  |  |  |  | }
314 |  |  |  |  |  | }
315 | 20 |  |  |  | 57 | close $fh;
316 | 20 40 | 100 |  |  | 25 152 | return map { $checksums{$_} || '' } qw(pre post);
317 |  |  |  |  |  | }
318 |
319 - 362 |  |
    =head2 Attributes generated by Moose

    All of this methods can also be set from the commandline. See
    MooseX::Getopts.

    =head3 dbh

    The database handle (DBH::db).

    =head3 dsn

    The dsn.

    =head3 user

    The user to use to connect to the DB.

    =head3 password

    The password to use to authenticate the user.

    =head3 catalog

    The database catalog searched for data. Not implemented by all DBs. See C<DBI::table_info>

    Default C<%>.

    =head3 schemata

    An Arrayref containg names of schematas to include in checksum calculation. See C<DBI::table_info>

    Default C<%>.

    =head3 tabletype

    What kind of tables to include in checksum calculation. See C<DBI::table_info>

    Default C<table>.

    =head3 verbose

    Be verbose or not. Default: 0

    =cut
363 |
364 |  |  |  |  |  | q{ Favourite record of the moment: The Dynamics - Version Excursions }
365 |