File Coverage

blib/lib/GitDDL/Migrator.pm
Criterion Covered Total %
statement 26 144 18.0
branch 0 40 0.0
condition 0 11 0.0
subroutine 9 29 31.0
pod 12 13 92.3
total 47 237 19.8


line stmt bran cond sub pod time code
1             package GitDDL::Migrator;
2 2     2   3318 use 5.008001;
  2         60  
3 2     2   8 use strict;
  2         3  
  2         35  
4 2     2   6 use warnings;
  2         6  
  2         68  
5              
6             our $VERSION = "0.08";
7              
8 2     2   5 use Carp qw/croak/;
  2         3  
  2         93  
9 2     2   878 use SQL::Translator;
  2         364282  
  2         48  
10 2     2   819 use SQL::Translator::Diff;
  2         9048  
  2         58  
11 2     2   448 use Time::HiRes qw/gettimeofday/;
  2         999  
  2         13  
12              
13 2     2   981 use Mouse;
  2         35448  
  2         7  
14             extends 'GitDDL';
15              
16             has ignore_tables => (
17             is => 'ro',
18             isa => 'ArrayRef',
19             default => sub { [] },
20             );
21              
22             has _db => (
23             is => 'ro',
24             default => sub {
25             my $self = shift;
26             my $dsn0 = $self->dsn->[0];
27             my $db
28             = $dsn0 =~ /:mysql:/ ? 'MySQL'
29             : $dsn0 =~ /:Pg:/ ? 'PostgreSQL'
30             : do { my ($d) = $dsn0 =~ /dbi:(.*?):/; $d };
31             },
32             );
33              
34             has real_translator => (
35             is => 'ro',
36             lazy => 1,
37             default => sub {
38             my $self = shift;
39             my $translator = SQL::Translator->new(
40             parser => 'DBI',
41             parser_args => +{ dbh => $self->_dbh },
42             );
43             $translator->translate;
44             $translator->producer($self->_db);
45              
46             if ($self->_db eq 'MySQL') {
47             # cut off AUTO_INCREMENT. see. http://bugs.mysql.com/bug.php?id=20786
48             my $schema = $translator->schema;
49             for my $table ($schema->get_tables) {
50             my @options = $table->options;
51             if (my ($idx) = grep { $options[$_]->{AUTO_INCREMENT} } 0..$#options) {
52             splice @{$table->options}, $idx, 1;
53             }
54             }
55             }
56             $translator;
57             },
58             );
59              
60 2     2   820 no Mouse;
  2         4  
  2         5  
61              
62             sub database_version {
63 0     0 1   my ($self, %args) = @_;
64              
65 0 0         my $back = defined $args{back} ? $args{back} : 0;
66              
67 0 0         croak sprintf 'invalid version_table: %s', $self->version_table
68             unless $self->version_table =~ /^[a-zA-Z_]+$/;
69              
70 0           local $@;
71 0           my @versions = eval {
72 0           open my $fh, '>', \my $stderr;
73 0           local *STDERR = $fh;
74 0           $self->_dbh->selectrow_array('SELECT version FROM ' . $self->version_table . ' ORDER BY upgraded_at DESC');
75             };
76              
77 0           return $versions[$back];
78             }
79              
80             sub deploy {
81 0     0 1   my $self = shift;
82              
83 0 0         if (@_) {
84 0           croak q[GitDDL::Migrator#deploy doesn't accepts any arguments]
85             }
86 0 0         if ($self->database_version) {
87 0           croak "database already deployed, use upgrade_database instead";
88             }
89              
90 0           my $sql = $self->_slurp(File::Spec->catfile($self->work_tree, $self->ddl_file));
91 0           $self->_do_sql($sql);
92              
93 0           $self->create_version_table($sql);
94             }
95              
96             sub create_version_table {
97 0     0 1   my ($self, $sql) = @_;
98              
99 0 0         $self->_do_sql(sprintf
100 0           "CREATE TABLE @{[ $self->version_table ]} (
101             version VARCHAR(40) NOT NULL,
102             upgraded_at VARCHAR(20) NOT NULL UNIQUE,
103             sql_text %s
104             );", $self->_db eq 'MySQL' ? 'LONGTEXT' : 'TEXT'
105             );
106              
107 0   0       $self->_insert_version(undef, $sql || '');
108             }
109              
110             sub _new_translator {
111 0     0     my $self = shift;
112              
113 0           my $translator = SQL::Translator->new;
114 0 0         $translator->parser($self->_db) or croak $translator->error;
115              
116 0           $translator;
117             }
118              
119             sub _new_translator_of_version {
120 0     0     my ($self, $version) = @_;
121              
122 0           my $tmp_fh = File::Temp->new;
123 0           $self->_dump_sql_for_specified_commit($version, $tmp_fh->filename);
124              
125 0           my $translator = $self->_new_translator;
126 0 0         $translator->translate($tmp_fh->filename) or croak $translator->error;
127              
128 0           $translator;
129             }
130              
131             sub _diff {
132 0     0     my ($self, $source, $target) = @_;
133              
134 0           my $diff = SQL::Translator::Diff->new({
135             output_db => $self->_db,
136             source_schema => $source->schema,
137             target_schema => $target->schema,
138             })->compute_differences->produce_diff_sql;
139              
140             # ignore first line
141 0           $diff =~ s/.*?\n//;
142              
143 0           $diff
144             }
145              
146             sub diff {
147 0     0 1   my ($self, %args) = @_;
148              
149 0           my $version = $args{version};
150 0           my $reverse = $args{reverse};
151              
152 0 0 0       if (!$version && $self->check_version) {
153 0           return '';
154             }
155 0           my $source = $self->_new_translator_of_version($self->database_version);
156              
157 0           my $target;
158 0 0         if (!$version) {
159 0           $target = $self->_new_translator;
160 0 0         $target->translate(File::Spec->catfile($self->work_tree, $self->ddl_file))
161             or croak $target->error;
162             }
163             else {
164 0           $target = $self->_new_translator_of_version($version);
165             }
166              
167 0 0         my ($from, $to) = !$reverse ? ($source, $target) : ($target, $source);
168 0           $self->_diff($from, $to);
169             }
170              
171 0     0 1   sub real_diff { goto \&diff_to_real_database }
172             sub diff_to_real_database {
173 0     0 1   my $self = shift;
174              
175 0           my $source = $self->_new_translator_of_version($self->database_version);
176 0           my $real = $self->real_translator;
177              
178 0           my $diff = SQL::Translator::Diff->new({
179             output_db => $self->_db,
180             source_schema => $source->schema,
181             target_schema => $real->schema,
182             })->compute_differences;
183              
184 0           my @tabls_to_create = @{ $diff->tables_to_create };
  0            
185 0           @tabls_to_create = grep {sub {
186 0     0     my $table_name = shift;
187 0 0         return () if $table_name eq $self->version_table;
188 0           ! grep { $table_name eq $_ } @{ $self->ignore_tables };
  0            
  0            
189 0           }->($_->name) } @tabls_to_create;
190 0           $diff->tables_to_create(\@tabls_to_create);
191              
192 0           my $diff_str = $diff->produce_diff_sql;
193             # ignore first line
194 0           $diff_str =~ s/.*?\n//;
195              
196 0           $diff_str;
197             }
198              
199             sub diff_from_real_database {
200 0     0 1   my $self = shift;
201              
202 0           my $target = $self->_new_translator_of_version($self->database_version);
203 0           my $real = $self->real_translator;
204              
205 0           my $diff = SQL::Translator::Diff->new({
206             output_db => $self->_db,
207             source_schema => $real->schema,
208             target_schema => $target->schema,
209             })->compute_differences;
210              
211 0           my @tabls_to_drop = @{ $diff->tables_to_drop };
  0            
212 0           @tabls_to_drop = grep {sub {
213 0     0     my $table_name = shift;
214 0 0         return () if $table_name eq $self->version_table;
215 0           ! grep { $table_name eq $_ } @{ $self->ignore_tables };
  0            
  0            
216 0           }->($_->name) } @tabls_to_drop;
217 0           $diff->tables_to_drop(\@tabls_to_drop);
218              
219 0           my $diff_str = $diff->produce_diff_sql;
220             # ignore first line
221 0           $diff_str =~ s/.*?\n//;
222              
223 0           $diff_str;
224             }
225              
226             sub check_ddl_mismatch {
227 0     0 1   my $self = shift;
228              
229 0           my $real_diff = $self->real_diff;
230 0 0         croak "Mismatch between ddl version and real database is found. Diff is:\n $real_diff"
231             unless $real_diff =~ /\A\s*-- No differences found;\s*\z/ms;
232             }
233              
234             sub get_rollback_version {
235 0     0 1   my $self = shift;
236              
237 0           my $sth = $self->_dbh->prepare('SELECT version FROM ' . $self->version_table . ' ORDER BY upgraded_at DESC');
238 0           $sth->execute;
239              
240 0           my ($current_version) = $sth->fetchrow_array;
241 0           my ($prev_version) = $sth->fetchrow_array;
242 0 0         croak 'No rollback target is found' unless $prev_version;
243              
244 0           $prev_version;
245             }
246              
247             sub rollback_diff {
248 0     0 1   my $self = shift;
249              
250 0           $self->diff(version => $self->get_rollback_version);
251             }
252              
253             sub upgrade_database {
254 0     0 1   my ($self, %args) = @_;
255 0 0         croak 'Failed to get database version, please deploy first' unless $self->database_version;
256              
257 0           my $version = $args{version};
258 0   0       my $sql = $args{sql} || $self->diff(version => $version);
259              
260 0 0         return if $sql =~ /\A\s*\z/ms;
261              
262 0           $self->_do_sql($sql);
263 0           $self->_insert_version($version, $sql);
264             }
265              
266             sub migrate {
267 0     0 1   my $self = shift;
268              
269 0 0         if (!$self->database_version) {
270 0           $self->deploy(@_);
271             }
272             else {
273 0           $self->upgrade_database(@_);
274             }
275             }
276              
277             sub _insert_version {
278 0     0     my ($self, $version, $sql) = @_;
279              
280 0   0       $version ||= $self->ddl_version;
281 0 0         unless (length($version) == 40) {
282 0           $version = $self->_restore_full_hash($version);
283             }
284              
285             # steal from DBIx::Schema::Versioned
286 0           my @tm = gettimeofday();
287 0           my @dt = gmtime ($tm[0]);
288 0           my $upgraded_at = sprintf("v%04d%02d%02d_%02d%02d%02d.%03.0f",
289             $dt[5] + 1900,
290             $dt[4] + 1,
291             $dt[3],
292             $dt[2],
293             $dt[1],
294             $dt[0],
295             int($tm[1] / 1000), # convert to millisecs
296             );
297              
298 0 0         $self->_dbh->do(
299 0           "INSERT INTO @{[ $self->version_table ]} (version, upgraded_at, sql_text) VALUES (?, ?, ?)", {}, $version, $upgraded_at, $sql
300             ) or croak $self->_dbh->errstr;
301             }
302              
303             sub _restore_full_hash {
304 0     0     my ($self, $version) = @_;
305 0           $self->_git->run('rev-parse', $version);
306             }
307              
308             sub vacuum {
309 0     0 0   die 'to be implemented';
310             # remove old verison hitosry.
311             }
312              
313             1;
314             __END__