File Coverage

blib/lib/App/Sqitch/Engine/mysql.pm
Criterion Covered Total %
statement 124 152 81.5
branch 24 34 70.5
condition 7 17 41.1
subroutine 44 52 84.6
pod 15 15 100.0
total 214 270 79.2


line stmt bran cond sub pod time code
1              
2             use 5.010;
3 4     4   226581 use strict;
  4         15  
4 4     4   20 use warnings;
  4         8  
  4         81  
5 4     4   18 use utf8;
  4         8  
  4         83  
6 4     4   22 use Try::Tiny;
  4         9  
  4         51  
7 4     4   108 use App::Sqitch::X qw(hurl);
  4         8  
  4         233  
8 4     4   26 use Locale::TextDomain qw(App-Sqitch);
  4         16  
  4         38  
9 4     4   1358 use App::Sqitch::Plan::Change;
  4         7  
  4         38  
10 4     4   765 use Path::Class;
  4         7  
  4         143  
11 4     4   24 use Moo;
  4         6  
  4         191  
12 4     4   30 use App::Sqitch::Types qw(DBH URIDB ArrayRef Bool Str HashRef);
  4         7  
  4         48  
13 4     4   1472 use namespace::autoclean;
  4         8  
  4         64  
14 4     4   4853 use List::MoreUtils qw(firstidx);
  4         9  
  4         31  
15 4     4   299  
  4         10  
  4         36  
16             extends 'App::Sqitch::Engine';
17              
18             our $VERSION = 'v1.3.1'; # VERSION
19              
20             has uri => (
21             is => 'ro',
22             isa => URIDB,
23             lazy => 1,
24             default => sub {
25             my $self = shift;
26             my $uri = $self->SUPER::uri;
27             $uri->host($ENV{MYSQL_HOST}) if !$uri->host && $ENV{MYSQL_HOST};
28             $uri->port($ENV{MYSQL_TCP_PORT}) if !$uri->_port && $ENV{MYSQL_TCP_PORT};
29             return $uri;
30             },
31             );
32              
33             has registry_uri => (
34             is => 'ro',
35             isa => URIDB,
36             lazy => 1,
37             default => sub {
38             my $self = shift;
39             my $uri = $self->uri->clone;
40             $uri->dbname($self->registry);
41             return $uri;
42             },
43             );
44              
45             my $uri = shift->registry_uri;
46             if ($uri->password) {
47 4     4 1 4680 $uri = $uri->clone;
48 4 100       57 $uri->password(undef);
49 1         74 }
50 1         24 return $uri->as_string;
51             }
52 4         212  
53             has _mycnf => (
54             is => 'rw',
55             isa => HashRef,
56             default => sub {
57             eval 'require MySQL::Config; 1' or return {};
58             return scalar MySQL::Config::parse_defaults('my', [qw(client mysql)]);
59             },
60             );
61              
62              
63             has dbh => (
64 4 50   4   802 is => 'rw',
65 6 100   6   1391 isa => DBH,
66             lazy => 1,
67             default => sub {
68             my $self = shift;
69             $self->use_driver;
70             my $uri = $self->registry_uri;
71             my $dbh = DBI->connect($uri->dbi_dsn, $self->username, $self->password, {
72             PrintError => 0,
73             RaiseError => 0,
74             AutoCommit => 1,
75             mysql_enable_utf8 => 1,
76             mysql_auto_reconnect => 0,
77             mysql_use_result => 0, # Prevent "Commands out of sync" error.
78             HandleError => sub {
79             my ($err, $dbh) = @_;
80             $@ = $err;
81             @_ = ($dbh->state || 'DEV' => $dbh->errstr);
82             goto &hurl;
83             },
84             Callbacks => {
85             connected => sub {
86             my $dbh = shift;
87             $dbh->do("SET SESSION $_") for (
88             q{character_set_client = 'utf8'},
89             q{character_set_server = 'utf8'},
90             ($dbh->{mysql_serverversion} || 0 < 50500 ? () : (q{default_storage_engine = 'InnoDB'})),
91             q{time_zone = '+00:00'},
92             q{group_concat_max_len = 32768},
93             q{sql_mode = '} . join(',', qw(
94             ansi
95             strict_trans_tables
96             no_auto_value_on_zero
97             no_zero_date
98             no_zero_in_date
99             only_full_group_by
100             error_for_division_by_zero
101             )) . q{'},
102             );
103             if (!$dbh->{mysql_serverversion} && DBI->VERSION < 1.631) {
104             # Prior to 1.631, callbacks were inner handles and
105             # mysql_* aren't set yet. So set InnoDB in a try block.
106             try {
107             $dbh->do(q{SET SESSION default_storage_engine = 'InnoDB'});
108             };
109             # https://www.nntp.perl.org/group/perl.dbi.dev/2013/11/msg7622.html
110             $dbh->set_err(undef, undef) if $dbh->err;
111             }
112             return;
113             },
114             },
115             });
116              
117             # Make sure we support this version.
118             my ($dbms, $vnum, $vstr) = $dbh->{mysql_serverinfo} =~ /mariadb/i
119             ? ('MariaDB', 50300, '5.3')
120             : ('MySQL', 50100, '5.1.0');
121             hurl mysql => __x(
122             'Sqitch requires {rdbms} {want_version} or higher; this is {have_version}',
123             rdbms => $dbms,
124             want_version => $vstr,
125             have_version => $dbh->selectcol_arrayref('SELECT version()')->[0],
126             ) unless $dbh->{mysql_serverversion} >= $vnum;
127              
128             return $dbh;
129             }
130             );
131              
132             has _ts_default => (
133             is => 'ro',
134             isa => Str,
135             lazy => 1,
136             default => sub {
137             return 'utc_timestamp(6)' if shift->_fractional_seconds;
138             return 'utc_timestamp';
139             },
140             );
141              
142             # Need to wait until dbh and _ts_default are defined.
143             with 'App::Sqitch::Role::DBIEngine';
144              
145             has _mysql => (
146             is => 'ro',
147             isa => ArrayRef,
148             lazy => 1,
149             default => sub {
150             my $self = shift;
151             my $uri = $self->uri;
152              
153             $self->sqitch->warn(__x
154             'Database name missing in URI "{uri}"',
155             uri => $uri
156             ) unless $uri->dbname;
157              
158             my @ret = ( $self->client );
159             # Use _port instead of port so it's empty if no port is in the URI.
160             # https://github.com/sqitchers/sqitch/issues/675
161             for my $spec (
162             [ user => $self->username ],
163             [ database => $uri->dbname ],
164             [ host => $uri->host ],
165             [ port => $uri->_port ],
166             ) {
167             push @ret, "--$spec->[0]" => $spec->[1] if $spec->[1];
168             }
169              
170             # Special-case --password, which requires = before the value. O_o
171             if (my $pw = $self->password) {
172             my $cfgpwd = $self->_mycnf->{password} || '';
173             push @ret, "--password=$pw" if $pw ne $cfgpwd;
174             }
175              
176             # Options to keep things quiet.
177             push @ret => (
178             (App::Sqitch::ISWIN ? () : '--skip-pager' ),
179             '--silent',
180             '--skip-column-names',
181             '--skip-line-numbers',
182             );
183              
184             # Get Maria to abort properly on error.
185             my $vinfo = try { $self->sqitch->probe($self->client, '--version') } || '';
186             if ($vinfo =~ /mariadb/i) {
187             my ($version) = $vinfo =~ /Ver\s(\S+)/;
188             my ($maj, undef, $pat) = split /[.]/ => $version;
189             push @ret => '--abort-source-on-error'
190             if $maj > 5 || ($maj == 5 && $pat >= 66);
191             }
192              
193             # Add relevant query args.
194             if (my @p = $uri->query_params) {
195             my %option_for = (
196             mysql_compression => sub { $_[0] ? '--compress' : () },
197             mysql_ssl => sub { $_[0] ? '--ssl' : () },
198             mysql_connect_timeout => sub { '--connect_timeout', $_[0] },
199             mysql_init_command => sub { '--init-command', $_[0] },
200             mysql_socket => sub { '--socket', $_[0] },
201             mysql_ssl_client_key => sub { '--ssl-key', $_[0] },
202             mysql_ssl_client_cert => sub { '--ssl-cert', $_[0] },
203             mysql_ssl_ca_file => sub { '--ssl-ca', $_[0] },
204             mysql_ssl_ca_path => sub { '--ssl-capath', $_[0] },
205             mysql_ssl_cipher => sub { '--ssl-cipher', $_[0] },
206             );
207             while (@p) {
208             my ($k, $v) = (shift @p, shift @p);
209             my $code = $option_for{$k} or next;
210             push @ret => $code->($v);
211             }
212             }
213              
214             return \@ret;
215             },
216             );
217              
218             has _fractional_seconds => (
219             is => 'ro',
220             isa => Bool,
221             lazy => 1,
222             default => sub {
223             my $dbh = shift->dbh;
224             return $dbh->{mysql_serverinfo} =~ /mariadb/i
225             ? $dbh->{mysql_serverversion} >= 50305
226             : $dbh->{mysql_serverversion} >= 50604;
227             },
228             );
229              
230              
231              
232             $_[1]->set_time_zone('UTC')->iso8601;
233             }
234 39     39 1 18540  
  39         943  
235             return q{date_format(%s, 'year:%%Y:month:%%m:day:%%d:hour:%%H:minute:%%i:second:%%S:time_zone:UTC')};
236 6     6 1 13443 }
237 5     5 1 43  
238 1     1 1 4 shift;
239 3     3 1 474 map { $_ eq 'change' ? '"change"' : $_ } @_;
240             }
241              
242 0     0   0  
243             has initialized => (
244             is => 'ro',
245             isa => Bool,
246 1     1   533 lazy => 1,
247             writer => '_set_initialized',
248             default => sub {
249             my $self = shift;
250 0     0   0  
251 0 0       0 # Try to connect.
  0         0  
252             my $dbh = try { $self->dbh } catch {
253             # MySQL error code 1049 (ER_BAD_DB_ERROR): Unknown database '%-.192s'
254 0     0   0 return if $DBI::err && $DBI::err == 1049;
255             die $_;
256             } or return 0;
257              
258             return $dbh->selectcol_arrayref(q{
259             SELECT COUNT(*)
260             FROM information_schema.tables
261             WHERE table_schema = ?
262             AND table_name = ?
263             }, undef, $self->registry, 'changes')->[0];
264             }
265             );
266              
267             my $self = shift;
268             hurl engine => __x(
269             'Sqitch database {database} already initialized',
270             database => $self->registry,
271             ) if $self->initialized;
272              
273             # Create the Sqitch database if it does not exist.
274             (my $db = $self->registry) =~ s/"/""/g;
275             $self->_run(
276             '--execute' => sprintf(
277             'SET sql_mode = ansi; CREATE DATABASE IF NOT EXISTS "%s"',
278             $self->registry
279             ),
280             );
281 0     0 1 0  
282 0 0       0 # Deploy the registry to the Sqitch database.
283             $self->run_upgrade( file(__FILE__)->dir->file('mysql.sql') );
284             $self->_set_initialized(1);
285             $self->_register_release;
286             }
287              
288 0         0 # Override to lock the Sqitch tables. This ensures that only one instance of
289 0         0 # Sqitch runs at one time.
290             my $self = shift;
291             my $dbh = $self->dbh;
292              
293             # Start transaction and lock all tables to disallow concurrent changes.
294             $dbh->do('LOCK TABLES ' . join ', ', map {
295             "$_ WRITE"
296             } qw(releases changes dependencies events projects tags));
297 0         0 $dbh->begin_work;
298 0         0 return $self;
299 0         0 }
300              
301             # We include the database name in the lock name because that's probably the most
302             # stringent lock the user expects. Locking the whole server with a static string
303             # prevents parallel deploys to other databases. Yes, locking just the target
304             # allows parallel deploys to conflict with one another if they make changes to
305 0     0 1 0 # other databases, but is not a great practice and likely an anti-pattern. So
306 0         0 # stick with the least surprising behavior.
307             # https://github.com/sqitchers/sqitch/issues/670
308             'sqitch working on ' . shift->uri->dbname
309             }
310 0         0  
  0         0  
311             # Override to try to acquire a lock on the string "sqitch working on $dbname"
312 0         0 # without waiting.
313 0         0 my $self = shift;
314             # Can't create a lock in the registry if it doesn't exist.
315             $self->initialize unless $self->initialized;
316             $self->dbh->selectcol_arrayref(
317             q{SELECT get_lock(?, ?)}, undef, $self->_lock_name, 0,
318             )->[0]
319             }
320              
321             # Override to try to acquire a lock on the string "sqitch working on $dbname",
322             # waiting for the lock until timeout.
323             my $self = shift;
324 3     3   1815 $self->dbh->selectcol_arrayref(
325             q{SELECT get_lock(?, ?)}, undef,
326             $self->_lock_name, $self->lock_timeout,
327             )->[0]
328             }
329              
330 0     0 1 0 # Override to unlock the tables, otherwise future transactions on this
331             # connection can fail.
332 0 0       0 my $self = shift;
333 0         0 my $dbh = $self->dbh;
334             $dbh->commit;
335             $dbh->do('UNLOCK TABLES');
336             return $self;
337             }
338              
339             return $DBI::state && (
340             $DBI::state eq '42S02' # ER_BAD_TABLE_ERROR
341 0     0 1 0 ||
342 0         0 ($DBI::state eq '42000' && $DBI::err == '1049') # ER_BAD_DB_ERROR
343             )
344             }
345              
346             return $DBI::state && $DBI::state eq '42S22' && $DBI::err == '1054'; # ER_BAD_FIELD_ERROR
347             }
348              
349              
350              
351 0     0 1 0 return q{GROUP_CONCAT(%1$s ORDER BY %1$s SEPARATOR ' ')};
352 0         0 }
353 0         0  
354 0         0 my ($self, $table, $change) = @_;
355 0         0 return $self if $self->_fractional_seconds;
356              
357             # No sub-second precision, so delay logging a change until a second has passed.
358             my $dbh = $self->dbh;
359 4   66 4   1400 my $sth = $dbh->prepare(qq{
360             SELECT UNIX_TIMESTAMP(committed_at) >= UNIX_TIMESTAMP()
361             FROM $table
362             WHERE project = ?
363             ORDER BY committed_at DESC
364             LIMIT 1
365             });
366             while ($dbh->selectcol_arrayref($sth, undef, $change->project)->[0]) {
367 4   66 4   34 # Sleep for 100 ms.
368             require Time::HiRes;
369             Time::HiRes::sleep(0.1);
370 2     2   10 }
371              
372 2     2   12 return $self;
373             }
374              
375 1     1   5833 my %vars = shift->variables or return;
376             return 'SET ' . join(', ', map {
377             (my $k = $_) =~ s/"/""/g;
378             (my $v = $vars{$_}) =~ s/'/''/g;
379 2     2   1153 qq{\@"$k" = '$v'};
380 2 100       11 } sort keys %vars) . ";\n";
381             }
382              
383 1         13 my ($self, $file) = @_;
384 1         11 my $set = $self->_set_vars || '';
385             return ('--execute' => "${set}source $file");
386             }
387              
388             my $self = shift;
389             my $sqitch = $self->sqitch;
390             my $pass = $self->password or return $sqitch->run( $self->mysql, @_ );
391 1         43 local $ENV{MYSQL_PWD} = $pass;
392             return $sqitch->run( $self->mysql, @_ );
393 1         82 }
394 1         5  
395             my $self = shift;
396             my $sqitch = $self->sqitch;
397 1         55 my $pass = $self->password or return $sqitch->capture( $self->mysql, @_ );
398             local $ENV{MYSQL_PWD} = $pass;
399             return $sqitch->capture( $self->mysql, @_ );
400             }
401 17 100   17   109  
402             my $self = shift;
403 5         79 my @fh = (shift);
  10         49  
404 10         28 my $sqitch = $self->sqitch;
405 10         63 if (my $set = $self->_set_vars) {
406             open my $sfh, '<:utf8_strict', \$set;
407             unshift @fh, $sfh;
408             }
409             my $pass = $self->password or return $sqitch->spool( \@fh, $self->mysql, @_ );
410 12     12   2709 local $ENV{MYSQL_PWD} = $pass;
411 12   100     52 return $sqitch->spool( \@fh, $self->mysql, @_ );
412 12         255 }
413              
414             my $self = shift;
415             $self->_run( $self->_source(@_) );
416 6     6   1729 }
417 6         33  
418 6 100       133 my $self = shift;
419 1         128 # Suppress STDOUT unless we want extra verbosity.
420 1         19 my $meth = $self->can($self->sqitch->verbosity > 1 ? '_run' : '_capture');
421             $self->$meth( $self->_source(@_) );
422             }
423              
424 4     4   790 my ($self, $file) = @_;
425 4         25 my @cmd = $self->mysql;
426 4 100       91 $cmd[1 + firstidx { $_ eq '--database' } @cmd ] = $self->registry;
427 1         55 return $self->sqitch->run( @cmd, $self->_source($file) )
428 1         12 if $self->_fractional_seconds;
429              
430             # Need to strip out datetime precision.
431             (my $sql = scalar $file->slurp) =~ s{DATETIME\(\d+\)}{DATETIME}g;
432 5     5   1576  
433 5         29 # Strip out 5.5 stuff on earlier versions.
434 5         28 $sql =~ s/-- ## BEGIN 5[.]5.+?-- ## END 5[.]5//ms
435 5 100       30 if $self->dbh->{mysql_serverversion} < 50500;
436 2     1   123  
  1     1   12  
  1         2  
  1         21  
  1         1375  
  1         4  
  1         7  
437 2         843 # Write out a temp file and execute it.
438             require File::Temp;
439 5 100       157 my $fh = File::Temp->new;
440 2         75 print $fh $sql;
441 2         32 close $fh;
442             $self->sqitch->run( @cmd, $self->_source($fh) );
443             }
444              
445 2     2 1 670 my ($self, $fh) = @_;
446 2         14 $self->_spool($fh);
447             }
448              
449             my ( $self, $ord, $offset, $project ) = @_;
450 4     4 1 3864  
451             my $offexpr = $offset ? " OFFSET $offset" : '';
452 4 100       78 return try {
453 4         282 return $self->dbh->selectcol_arrayref(qq{
454             SELECT change_id
455             FROM changes
456             WHERE project = ?
457 3     3 1 4407 ORDER BY committed_at $ord
458 3         17 LIMIT 1$offexpr
459 3     12   93 }, undef, $project || $self->plan->project)->[0];
  12         178  
460 3 100       21 } catch {
461             # MySQL error code 1049 (ER_BAD_DB_ERROR): Unknown database '%-.192s'
462             # MySQL error code 1146 (ER_NO_SUCH_TABLE): Table '%s.%s' doesn't exist
463             return if $DBI::err && ($DBI::err == 1049 || $DBI::err == 1146);
464 2         37 die $_;
465             };
466             }
467              
468 2 100       880 1;
469              
470             1;
471 2         51  
472 2         23  
473 2         3614 =head1 Name
474 2         125  
475 2         54 App::Sqitch::Engine::mysql - Sqitch MySQL Engine
476              
477             =head1 Synopsis
478              
479 2     2 1 1290 my $mysql = App::Sqitch::Engine->load( engine => 'mysql' );
480 2         11  
481             =head1 Description
482              
483             App::Sqitch::Engine::mysql provides the MySQL storage engine for Sqitch. It
484 1     1   399 supports MySQL 5.1.0 and higher (best on 5.6.4 and higher), as well as MariaDB
485             5.3.0 and higher.
486 1 50       6  
487             =head1 Interface
488 1   0 1   41  
489             =head2 Instance Methods
490              
491             =head3 C<mysql>
492              
493             Returns a list containing the C<mysql> client and options to be passed to it.
494             Used internally when executing scripts. Query parameters in the URI that map
495             to C<mysql> client options will be passed to the client, as follows:
496              
497             =over
498 1 0 0 1   24  
      33        
499 1         8 =item * C<mysql_compression=1>: C<--compress>
500 1         18  
501             =item * C<mysql_ssl=1>: C<--ssl>
502              
503             =item * C<mysql_connect_timeout>: C<--connect_timeout>
504              
505             =item * C<mysql_init_command>: C<--init-command>
506              
507             =item * C<mysql_socket>: C<--socket>
508              
509             =item * C<mysql_ssl_client_key>: C<--ssl-key>
510              
511             =item * C<mysql_ssl_client_cert>: C<--ssl-cert>
512              
513             =item * C<mysql_ssl_ca_file>: C<--ssl-ca>
514              
515             =item * C<mysql_ssl_ca_path>: C<--ssl-capath>
516              
517             =item * C<mysql_ssl_cipher>: C<--ssl-cipher>
518              
519             =back
520              
521             =head3 C<username>
522              
523             =head3 C<password>
524              
525             Overrides the methods provided by the target so that, if the target has
526             no username or password, Sqitch looks them up in the
527             L<F</etc/my.cnf> and F<~/.my.cnf> files|https://dev.mysql.com/doc/refman/5.7/en/password-security-user.html>.
528             These files must limit access only to the current user (C<0600>). Sqitch will
529             look for a username and password under the C<[client]> and C<[mysql]>
530             sections, in that order.
531              
532             =head1 Author
533              
534             David E. Wheeler <david@justatheory.com>
535              
536             =head1 License
537              
538             Copyright (c) 2012-2022 iovation Inc., David E. Wheeler
539              
540             Permission is hereby granted, free of charge, to any person obtaining a copy
541             of this software and associated documentation files (the "Software"), to deal
542             in the Software without restriction, including without limitation the rights
543             to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
544             copies of the Software, and to permit persons to whom the Software is
545             furnished to do so, subject to the following conditions:
546              
547             The above copyright notice and this permission notice shall be included in all
548             copies or substantial portions of the Software.
549              
550             THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
551             IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
552             FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
553             AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
554             LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
555             OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
556             SOFTWARE.
557              
558             =cut