File Coverage

blib/lib/App/Sqitch/Role/DBIEngine.pm
Criterion Covered Total %
statement 72 337 21.3
branch 18 112 16.0
condition 8 54 14.8
subroutine 26 74 35.1
pod 27 27 100.0
total 151 604 25.0


line stmt bran cond sub pod time code
1             package App::Sqitch::Role::DBIEngine;
2              
3 29     29   145846 use 5.010;
  29         156  
4 29     29   199 use strict;
  29         79  
  29         794  
5 29     29   220 use warnings;
  29         122  
  29         1055  
6 29     29   221 use utf8;
  29         87  
  29         247  
7 29     29   27668 use DBI 1.631;
  29         282746  
  29         1749  
8 29     29   1039 use Moo::Role;
  29         19106  
  29         298  
9 29     29   14499 use Try::Tiny;
  29         1545  
  29         1953  
10 29     29   730 use App::Sqitch::X qw(hurl);
  29         99  
  29         315  
11 29     29   12263 use Locale::TextDomain qw(App-Sqitch);
  29         19545  
  29         305  
12 29     29   26424 use namespace::autoclean;
  29         12804  
  29         317  
13              
14             our $VERSION = 'v1.4.0'; # VERSION
15              
16             requires 'dbh';
17             requires 'sqitch';
18             requires 'plan';
19             requires '_regex_op';
20             requires '_ts2char_format';
21             requires '_char2ts';
22             requires '_listagg_format';
23             requires '_no_table_error';
24             requires '_unique_error';
25             requires '_handle_lookup_index';
26             requires '_no_registry';
27             requires 'initialized';
28              
29             # Called on connect if the registry schema does not exist.
30             sub _handle_no_registry {
31 0     0   0 my ($self, $dbh) = @_;
32             # https://www.nntp.perl.org/group/perl.dbi.dev/2013/11/msg7622.html
33 0         0 $dbh->set_err(undef, undef);
34 0         0 $self->_no_registry(1);
35 0         0 return;
36             }
37              
38             after use_driver => sub {
39             DBI->trace(1) if $_[0]->sqitch->verbosity > 2;
40             };
41              
42             sub _dt($) {
43 2     2   2005 require App::Sqitch::DateTime;
44 2         38 return App::Sqitch::DateTime->new(split /:/ => shift);
45             }
46              
47             sub _log_tags_param {
48 0     0   0 join ' ' => map { $_->format_name } $_[1]->tags;
  0         0  
49             }
50              
51             sub _log_requires_param {
52 0     0   0 join ',' => map { $_->as_string } $_[1]->requires;
  0         0  
53             }
54              
55             sub _log_conflicts_param {
56 0     0   0 join ',' => map { $_->as_string } $_[1]->conflicts;
  0         0  
57             }
58              
59 1     1   1932 sub _ts_default { 'DEFAULT' }
60              
61 0     0   0 sub _can_limit { 1 }
62 1     1   8 sub _limit_default { undef }
63              
64 1     1   8 sub _simple_from { '' }
65              
66 0     0   0 sub _quote_idents { shift; @_ }
  0         0  
67              
68             sub _in_expr {
69 0     0   0 my ($self, $vals) = @_;
70 0         0 my $in = sprintf 'IN (%s)', join ', ', ('?') x @{ $vals };
  0         0  
71 0         0 return $in, @{ $vals };
  0         0  
72             }
73              
74             sub _register_release {
75 0     0   0 my $self = shift;
76 0   0     0 my $version = shift || $self->registry_release;
77 0         0 my $sqitch = $self->sqitch;
78 0         0 my $ts = $self->_ts_default;
79              
80 0         0 $self->begin_work;
81 0         0 $self->dbh->do(qq{
82             INSERT INTO releases (version, installed_at, installer_name, installer_email)
83             VALUES (?, $ts, ?, ?)
84             }, undef, $version, $sqitch->user_name, $sqitch->user_email);
85 0         0 $self->finish_work;
86 0         0 return $self;
87             }
88              
89 0     0   0 sub _version_query { 'SELECT MAX(version) FROM releases' }
90              
91             sub registry_version {
92 2     2 1 1018 my $self = shift;
93             try {
94 2     2   266 $self->dbh->selectcol_arrayref($self->_version_query)->[0];
95             } catch {
96 2 100   2   57 return 0 if $self->_no_table_error;
97 1         12 die $_;
98 2         16 };
99             }
100              
101             sub _cid {
102 2     2   49 my ( $self, $ord, $offset, $project ) = @_;
103             return try {
104 2   0 2   167 $self->dbh->selectcol_arrayref(qq{
105             SELECT change_id
106             FROM changes
107             WHERE project = ?
108             ORDER BY committed_at $ord
109             LIMIT 1
110             OFFSET COALESCE(?, 0)
111             }, undef, $project || $self->plan->project, $offset)->[0];
112             } catch {
113 2 100 66 2   39 return if $self->_no_table_error && !$self->initialized;
114 1         11 die $_;
115 2         16 };
116             }
117              
118             sub earliest_change_id {
119 0     0 1 0 shift->_cid('ASC', @_);
120             }
121              
122             sub latest_change_id {
123 0     0 1 0 shift->_cid('DESC', @_);
124             }
125              
126             sub _select_state {
127 0     0   0 my ( $self, $project, $with_hash ) = @_;
128 0         0 my $cdtcol = sprintf $self->_ts2char_format, 'c.committed_at';
129 0         0 my $pdtcol = sprintf $self->_ts2char_format, 'c.planned_at';
130 0         0 my $tagcol = sprintf $self->_listagg_format, 't.tag';
131 0 0       0 my $hshcol = $with_hash ? "c.script_hash\n , " : '';
132 0         0 my $dbh = $self->dbh;
133 0   0     0 $dbh->selectrow_hashref(qq{
134             SELECT c.change_id
135             , ${hshcol}c.change
136             , c.project
137             , c.note
138             , c.committer_name
139             , c.committer_email
140             , $cdtcol AS committed_at
141             , c.planner_name
142             , c.planner_email
143             , $pdtcol AS planned_at
144             , $tagcol AS tags
145             FROM changes c
146             LEFT JOIN tags t ON c.change_id = t.change_id
147             WHERE c.project = ?
148             GROUP BY c.change_id
149             , ${hshcol}c.change
150             , c.project
151             , c.note
152             , c.committer_name
153             , c.committer_email
154             , c.committed_at
155             , c.planner_name
156             , c.planner_email
157             , c.planned_at
158             ORDER BY c.committed_at DESC
159             LIMIT 1
160             }, undef, $project // $self->plan->project );
161             }
162              
163             sub current_state {
164 3     3 1 89 my ( $self, $project ) = @_;
165             my $state = try {
166 3     3   274 $self->_select_state($project, 1)
167             } catch {
168 3 100 100 3   68 return if $self->_no_table_error && !$self->initialized;
169 2 100       16 return $self->_select_state($project, 0) if $self->_no_column_error;
170 1         11 die $_;
171 3 50       21 } or return undef;
172              
173 0 0       0 unless (ref $state->{tags}) {
174 0 0       0 $state->{tags} = $state->{tags} ? [ split / / => $state->{tags} ] : [];
175             }
176 0         0 $state->{committed_at} = _dt $state->{committed_at};
177 0         0 $state->{planned_at} = _dt $state->{planned_at};
178 0         0 return $state;
179             }
180              
181             sub current_changes {
182 0     0 1 0 my ( $self, $project ) = @_;
183 0         0 my $cdtcol = sprintf $self->_ts2char_format, 'c.committed_at';
184 0         0 my $pdtcol = sprintf $self->_ts2char_format, 'c.planned_at';
185 0         0 my $sth = $self->dbh->prepare(qq{
186             SELECT c.change_id
187             , c.script_hash
188             , c.change
189             , c.committer_name
190             , c.committer_email
191             , $cdtcol AS committed_at
192             , c.planner_name
193             , c.planner_email
194             , $pdtcol AS planned_at
195             FROM changes c
196             WHERE project = ?
197             ORDER BY c.committed_at DESC
198             });
199 0   0     0 $sth->execute($project // $self->plan->project);
200             return sub {
201 0 0   0   0 my $row = $sth->fetchrow_hashref or return;
202 0         0 $row->{committed_at} = _dt $row->{committed_at};
203 0         0 $row->{planned_at} = _dt $row->{planned_at};
204 0         0 return $row;
205 0         0 };
206             }
207              
208             sub current_tags {
209 0     0 1 0 my ( $self, $project ) = @_;
210 0         0 my $cdtcol = sprintf $self->_ts2char_format, 'committed_at';
211 0         0 my $pdtcol = sprintf $self->_ts2char_format, 'planned_at';
212 0         0 my $sth = $self->dbh->prepare(qq{
213             SELECT tag_id
214             , tag
215             , committer_name
216             , committer_email
217             , $cdtcol AS committed_at
218             , planner_name
219             , planner_email
220             , $pdtcol AS planned_at
221             FROM tags
222             WHERE project = ?
223             ORDER BY tags.committed_at DESC
224             });
225 0   0     0 $sth->execute($project // $self->plan->project);
226             return sub {
227 0 0   0   0 my $row = $sth->fetchrow_hashref or return;
228 0         0 $row->{committed_at} = _dt $row->{committed_at};
229 0         0 $row->{planned_at} = _dt $row->{planned_at};
230 0         0 return $row;
231 0         0 };
232             }
233              
234             sub search_events {
235 0     0 1 0 my ( $self, %p ) = @_;
236              
237             # Determine order direction.
238 0         0 my $dir = 'DESC';
239 0 0       0 if (my $d = delete $p{direction}) {
240 0 0       0 $dir = $d =~ /^ASC/i ? 'ASC'
    0          
241             : $d =~ /^DESC/i ? 'DESC'
242             : hurl 'Search direction must be either "ASC" or "DESC"';
243             }
244              
245             # Limit with regular expressions?
246 0         0 my (@wheres, @params);
247 0         0 for my $spec (
248             [ committer => 'e.committer_name' ],
249             [ planner => 'e.planner_name' ],
250             [ change => 'e.change' ],
251             [ project => 'e.project' ],
252             ) {
253 0   0     0 my $regex = delete $p{ $spec->[0] } // next;
254 0         0 my ($op, $expr) = $self->_regex_expr($spec->[1], $regex);
255 0         0 push @wheres => $op;
256 0         0 push @params => $expr;
257             }
258              
259             # Match events?
260 0 0       0 if (my $e = delete $p{event} ) {
261 0         0 my ($in, @vals) = $self->_in_expr( $e );
262 0         0 push @wheres => "e.event $in";
263 0         0 push @params => @vals;
264             }
265              
266             # Assemble the where clause.
267 0 0       0 my $where = @wheres
268             ? "\n WHERE " . join( "\n ", @wheres )
269             : '';
270              
271             # Handle remaining parameters.
272 0         0 my $limits = '';
273 0 0 0     0 if (exists $p{limit} || exists $p{offset}) {
274 0         0 my ($exprs, $values) = $self->_limit_offset(delete $p{limit}, delete $p{offset});
275 0 0       0 if (@{ $exprs}) {
  0         0  
276 0         0 $limits = join "\n ", '', @{ $exprs };
  0         0  
277 0 0       0 push @params => @{ $values || [] };
  0         0  
278             }
279             }
280              
281 0 0       0 hurl 'Invalid parameters passed to search_events(): '
282             . join ', ', sort keys %p if %p;
283              
284             # Prepare, execute, and return.
285 0         0 my $cdtcol = sprintf $self->_ts2char_format, 'e.committed_at';
286 0         0 my $pdtcol = sprintf $self->_ts2char_format, 'e.planned_at';
287 0         0 my $sth = $self->dbh->prepare(qq{
288             SELECT e.event
289             , e.project
290             , e.change_id
291             , e.change
292             , e.note
293             , e.requires
294             , e.conflicts
295             , e.tags
296             , e.committer_name
297             , e.committer_email
298             , $cdtcol AS committed_at
299             , e.planner_name
300             , e.planner_email
301             , $pdtcol AS planned_at
302             FROM events e$where
303             ORDER BY e.committed_at $dir$limits
304             });
305              
306 0         0 $sth->execute(@params);
307             return sub {
308 0 0   0   0 my $row = $sth->fetchrow_hashref or return;
309 0         0 $row->{committed_at} = _dt $row->{committed_at};
310 0         0 $row->{planned_at} = _dt $row->{planned_at};
311 0         0 return $row;
312 0         0 };
313             }
314              
315             sub _regex_expr {
316 1     1   10 my ( $self, $col, $regex ) = @_;
317 1         7 my $op = $self->_regex_op;
318 1         11 return "$col $op ?", $regex;
319             }
320              
321             sub _limit_offset {
322 6     6   329 my ($self, $lim, $off) = @_;
323 6         14 my (@limits, @params);
324              
325 6 100       16 if ($lim) {
326 3         11 push @limits => 'LIMIT ?';
327 3         7 push @params => $lim;
328             }
329 6 100       14 if ($off) {
330 2 100 66     12 if (!$lim && ($lim = $self->_limit_default)) {
331             # Some drivers require LIMIT when OFFSET is set.
332 1         12 push @limits => 'LIMIT ?';
333 1         7 push @params => $lim;
334             }
335 2         10 push @limits => 'OFFSET ?';
336 2         6 push @params => $off;
337             }
338 6         55 return \@limits, \@params;
339             }
340              
341             sub registered_projects {
342 0     0 1 0 return @{ shift->dbh->selectcol_arrayref(
343 0         0 'SELECT project FROM projects ORDER BY project'
344             ) };
345             }
346              
347             sub register_project {
348 0     0 1 0 my $self = shift;
349 0         0 my $sqitch = $self->sqitch;
350 0         0 my $dbh = $self->dbh;
351 0         0 my $plan = $self->plan;
352 0         0 my $proj = $plan->project;
353 0         0 my $uri = $plan->uri;
354              
355 0         0 my $res = $dbh->selectcol_arrayref(
356             'SELECT uri FROM projects WHERE project = ?',
357             undef, $proj
358             );
359              
360 0 0       0 if (@{ $res }) {
  0         0  
361             # A project with that name is already registered. Compare URIs.
362 0         0 my $reg_uri = $res->[0];
363 0 0 0     0 if ( defined $uri && !defined $reg_uri ) {
    0 0        
    0 0        
364 0         0 hurl engine => __x(
365             'Cannot register "{project}" with URI {uri}: already exists with NULL URI',
366             project => $proj,
367             uri => $uri
368             );
369             } elsif ( !defined $uri && defined $reg_uri ) {
370 0         0 hurl engine => __x(
371             'Cannot register "{project}" without URI: already exists with URI {uri}',
372             project => $proj,
373             uri => $reg_uri
374             );
375             } elsif ( defined $uri && defined $reg_uri ) {
376 0 0       0 hurl engine => __x(
377             'Cannot register "{project}" with URI {uri}: already exists with URI {reg_uri}',
378             project => $proj,
379             uri => $uri,
380             reg_uri => $reg_uri,
381             ) if $uri ne $reg_uri;
382             } else {
383             # Both are undef, so cool.
384             }
385             } else {
386             # No project with that name exists. Check to see if the URI does.
387 0 0       0 if (defined $uri) {
388             # Does the URI already exist?
389 0         0 my $res = $dbh->selectcol_arrayref(
390             'SELECT project FROM projects WHERE uri = ?',
391             undef, $uri
392             );
393              
394             hurl engine => __x(
395             'Cannot register "{project}" with URI {uri}: project "{reg_proj}" already using that URI',
396             project => $proj,
397             uri => $uri,
398             reg_proj => $res->[0],
399 0 0       0 ) if @{ $res };
  0         0  
400             }
401              
402             # Insert the project.
403 0         0 my $ts = $self->_ts_default;
404 0         0 $dbh->do(qq{
405             INSERT INTO projects (project, uri, creator_name, creator_email, created_at)
406             VALUES (?, ?, ?, ?, $ts)
407             }, undef, $proj, $uri, $sqitch->user_name, $sqitch->user_email);
408             }
409              
410 0         0 return $self;
411             }
412              
413             sub is_deployed_change {
414 0     0 1 0 my ( $self, $change ) = @_;
415 0         0 $self->dbh->selectcol_arrayref(q{
416             SELECT EXISTS(
417             SELECT 1
418             FROM changes
419             WHERE change_id = ?
420             )
421             }, undef, $change->id)->[0];
422             }
423              
424             sub are_deployed_changes {
425 0     0 1 0 my $self = shift;
426 0         0 my $qs = join ', ' => ('?') x @_;
427 0         0 @{ $self->dbh->selectcol_arrayref(
428             "SELECT change_id FROM changes WHERE change_id IN ($qs)",
429             undef,
430 0         0 map { $_->id } @_,
  0         0  
431             ) };
432             }
433              
434             sub is_deployed_tag {
435 0     0 1 0 my ( $self, $tag ) = @_;
436 0         0 return $self->dbh->selectcol_arrayref(q{
437             SELECT EXISTS(
438             SELECT 1
439             FROM tags
440             WHERE tag_id = ?
441             );
442             }, undef, $tag->id)->[0];
443             }
444              
445             sub _multi_values {
446 0     0   0 my ($self, $count, $expr) = @_;
447 0         0 return 'VALUES ' . join(', ', ("($expr)") x $count)
448             }
449              
450             sub _dependency_placeholders {
451 0     0   0 return '?, ?, ?, ?';
452             }
453              
454             sub _tag_placeholders {
455 0     0   0 my $self = shift;
456 0         0 return '?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ' . $self->_ts_default;
457             }
458              
459             sub _tag_subselect_columns {
460 0     0   0 my $self = shift;
461 0         0 return join(', ',
462             '? AS tid',
463             '? AS tname',
464             '? AS proj',
465             '? AS cid',
466             '? AS note',
467             '? AS cuser',
468             '? AS cemail',
469             '? AS tts',
470             '? AS puser',
471             '? AS pemail',
472             $self->_ts_default,
473             );
474             }
475              
476 0     0   0 sub _prepare_to_log { $_[0] }
477              
478             sub log_deploy_change {
479 0     0 1 0 my ($self, $change) = @_;
480 0         0 my $dbh = $self->dbh;
481 0         0 my $sqitch = $self->sqitch;
482              
483 0         0 my ($id, $name, $proj, $user, $email) = (
484             $change->id,
485             $change->format_name,
486             $change->project,
487             $sqitch->user_name,
488             $sqitch->user_email
489             );
490              
491 0         0 my $ts = $self->_ts_default;
492 0         0 my $cols = join "\n , ", $self->_quote_idents(qw(
493             change_id
494             script_hash
495             change
496             project
497             note
498             committer_name
499             committer_email
500             planned_at
501             planner_name
502             planner_email
503             committed_at
504             ));
505              
506 0         0 $self->_prepare_to_log(changes => $change);
507             try {
508 0     0   0 $dbh->do(qq{
509             INSERT INTO changes (
510             $cols
511             )
512             VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, $ts)
513             }, undef,
514             $id,
515             $change->script_hash,
516             $name,
517             $proj,
518             $change->note,
519             $user,
520             $email,
521             $self->_char2ts( $change->timestamp ),
522             $change->planner_name,
523             $change->planner_email,
524             )
525             } catch {
526 0 0   0   0 hurl engine => __x(
527             'Cannot log change "{change}": The deploy script is not unique',
528             change => $name,
529             ) if $self->_unique_error;
530 0         0 die $_;
531 0         0 };
532              
533 0 0       0 if ( my @deps = $change->dependencies ) {
534             $dbh->do(q{
535             INSERT INTO dependencies(
536             change_id
537             , type
538             , dependency
539             , dependency_id
540             ) } . $self->_multi_values(scalar @deps, $self->_dependency_placeholders),
541             undef,
542 0         0 map { (
543 0         0 $id,
544             $_->type,
545             $_->as_string,
546             $_->resolved_id,
547             ) } @deps
548             );
549             }
550              
551 0 0       0 if ( my @tags = $change->tags ) {
552             $dbh->do(q{
553             INSERT INTO tags (
554             tag_id
555             , tag
556             , project
557             , change_id
558             , note
559             , committer_name
560             , committer_email
561             , planned_at
562             , planner_name
563             , planner_email
564             , committed_at
565             ) } . $self->_multi_values(scalar @tags, $self->_tag_placeholders),
566             undef,
567 0         0 map { (
568 0         0 $_->id,
569             $_->format_name,
570             $proj,
571             $id,
572             $_->note,
573             $user,
574             $email,
575             $self->_char2ts( $_->timestamp ),
576             $_->planner_name,
577             $_->planner_email,
578             ) } @tags
579             );
580             }
581              
582 0         0 return $self->_log_event( deploy => $change );
583             }
584              
585             sub log_fail_change {
586 0     0 1 0 shift->_log_event( fail => shift );
587             }
588              
589             sub _log_event {
590 0     0   0 my ( $self, $event, $change, $tags, $requires, $conflicts) = @_;
591 0         0 my $dbh = $self->dbh;
592 0         0 my $sqitch = $self->sqitch;
593              
594 0         0 my $ts = $self->_ts_default;
595 0         0 my $cols = join "\n , ", $self->_quote_idents(qw(
596             event
597             change_id
598             change
599             project
600             note
601             tags
602             requires
603             conflicts
604             committer_name
605             committer_email
606             planned_at
607             planner_name
608             planner_email
609             committed_at
610             ));
611              
612 0         0 $self->_prepare_to_log(events => $change);
613 0   0     0 $dbh->do(qq{
      0        
      0        
614             INSERT INTO events (
615             $cols
616             )
617             VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, $ts)
618             }, undef,
619             $event,
620             $change->id,
621             $change->name,
622             $change->project,
623             $change->note,
624             $tags || $self->_log_tags_param($change),
625             $requires || $self->_log_requires_param($change),
626             $conflicts || $self->_log_conflicts_param($change),
627             $sqitch->user_name,
628             $sqitch->user_email,
629             $self->_char2ts( $change->timestamp ),
630             $change->planner_name,
631             $change->planner_email,
632             );
633              
634 0         0 return $self;
635             }
636              
637             sub changes_requiring_change {
638 0     0 1 0 my ( $self, $change ) = @_;
639 0         0 return @{ $self->dbh->selectall_arrayref(q{
  0         0  
640             SELECT c.change_id, c.project, c.change, (
641             SELECT tag
642             FROM changes c2
643             JOIN tags ON c2.change_id = tags.change_id
644             WHERE c2.project = c.project
645             AND c2.committed_at >= c.committed_at
646             ORDER BY c2.committed_at
647             LIMIT 1
648             ) AS asof_tag
649             FROM dependencies d
650             JOIN changes c ON c.change_id = d.change_id
651             WHERE d.dependency_id = ?
652             }, { Slice => {} }, $change->id) };
653             }
654              
655             sub name_for_change_id {
656 0     0 1 0 my ( $self, $change_id ) = @_;
657 0         0 return $self->dbh->selectcol_arrayref(q{
658             SELECT c.change || COALESCE((
659             SELECT tag
660             FROM changes c2
661             JOIN tags ON c2.change_id = tags.change_id
662             WHERE c2.committed_at >= c.committed_at
663             AND c2.project = c.project
664             LIMIT 1
665             ), '@HEAD')
666             FROM changes c
667             WHERE change_id = ?
668             }, undef, $change_id)->[0];
669             }
670              
671             sub log_new_tags {
672 0     0 1 0 my ( $self, $change ) = @_;
673 0 0       0 my @tags = $change->tags or return $self;
674 0         0 my $sqitch = $self->sqitch;
675              
676 0         0 my ($id, $name, $proj, $user, $email) = (
677             $change->id,
678             $change->format_name,
679             $change->project,
680             $sqitch->user_name,
681             $sqitch->user_email
682             );
683              
684 0         0 my $subselect = 'SELECT ' . $self->_tag_subselect_columns . $self->_simple_from;
685             $self->dbh->do(
686             q{
687             INSERT INTO tags (
688             tag_id
689             , tag
690             , project
691             , change_id
692             , note
693             , committer_name
694             , committer_email
695             , planned_at
696             , planner_name
697             , planner_email
698             , committed_at
699             )
700             SELECT i.* FROM (
701             } . join(
702             "\n UNION ALL ",
703             ($subselect) x @tags
704             ) . q{
705             ) i
706             LEFT JOIN tags ON i.tid = tags.tag_id
707             WHERE tags.tag_id IS NULL
708             },
709             undef,
710 0         0 map { (
711 0         0 $_->id,
712             $_->format_name,
713             $proj,
714             $id,
715             $_->note,
716             $user,
717             $email,
718             $self->_char2ts( $_->timestamp ),
719             $_->planner_name,
720             $_->planner_email,
721             ) } @tags
722             );
723              
724 0         0 return $self;
725             }
726              
727             sub log_revert_change {
728 0     0 1 0 my ($self, $change) = @_;
729 0         0 my $dbh = $self->dbh;
730 0         0 my $cid = $change->id;
731              
732             # Retrieve and delete tags.
733 0 0       0 my $del_tags = join ',' => @{ $dbh->selectcol_arrayref(
  0         0  
734             'SELECT tag FROM tags WHERE change_id = ?',
735             undef, $cid
736             ) || [] };
737              
738 0         0 $dbh->do(
739             'DELETE FROM tags WHERE change_id = ?',
740             undef, $cid
741             );
742              
743             # Retrieve dependencies and delete.
744 0         0 my $sth = $dbh->prepare(q{
745             SELECT dependency
746             FROM dependencies
747             WHERE change_id = ?
748             AND type = ?
749             });
750 0         0 my $req = join ',' => @{ $dbh->selectcol_arrayref(
  0         0  
751             $sth, undef, $cid, 'require'
752             ) };
753              
754 0         0 my $conf = join ',' => @{ $dbh->selectcol_arrayref(
  0         0  
755             $sth, undef, $cid, 'conflict'
756             ) };
757              
758 0         0 $dbh->do('DELETE FROM dependencies WHERE change_id = ?', undef, $cid);
759              
760             # Delete the change record.
761 0         0 $dbh->do(
762             'DELETE FROM changes where change_id = ?',
763             undef, $cid,
764             );
765              
766             # Log it.
767 0         0 return $self->_log_event( revert => $change, $del_tags, $req, $conf );
768             }
769              
770             sub deployed_changes {
771 0     0 1 0 my $self = shift;
772 0         0 my $tscol = sprintf $self->_ts2char_format, 'c.planned_at';
773 0         0 my $tagcol = sprintf $self->_listagg_format, 't.tag';
774             return map {
775 0         0 $_->{timestamp} = _dt $_->{timestamp};
776 0 0       0 unless (ref $_->{tags}) {
777 0 0       0 $_->{tags} = $_->{tags} ? [ split / / => $_->{tags} ] : [];
778             }
779 0         0 $_;
780 0         0 } @{ $self->dbh->selectall_arrayref(qq{
  0         0  
781             SELECT c.change_id AS id, c.change AS name, c.project, c.note,
782             $tscol AS "timestamp", c.planner_name, c.planner_email,
783             $tagcol AS tags, c.script_hash
784             FROM changes c
785             LEFT JOIN tags t ON c.change_id = t.change_id
786             WHERE c.project = ?
787             GROUP BY c.change_id, c.change, c.project, c.note, c.planned_at,
788             c.planner_name, c.planner_email, c.committed_at, c.script_hash
789             ORDER BY c.committed_at ASC
790             }, { Slice => {} }, $self->plan->project) };
791             }
792              
793             sub deployed_changes_since {
794 0     0 1 0 my ( $self, $change ) = @_;
795 0         0 my $tscol = sprintf $self->_ts2char_format, 'c.planned_at';
796 0         0 my $tagcol = sprintf $self->_listagg_format, 't.tag';
797             return map {
798 0         0 $_->{timestamp} = _dt $_->{timestamp};
799 0 0       0 unless (ref $_->{tags}) {
800 0 0       0 $_->{tags} = $_->{tags} ? [ split / / => $_->{tags} ] : [];
801             }
802 0         0 $_;
803 0         0 } @{ $self->dbh->selectall_arrayref(qq{
  0         0  
804             SELECT c.change_id AS id, c.change AS name, c.project, c.note,
805             $tscol AS "timestamp", c.planner_name, c.planner_email,
806             $tagcol AS tags, c.script_hash
807             FROM changes c
808             LEFT JOIN tags t ON c.change_id = t.change_id
809             WHERE c.project = ?
810             AND c.committed_at > (SELECT committed_at FROM changes WHERE change_id = ?)
811             GROUP BY c.change_id, c.change, c.project, c.note, c.planned_at,
812             c.planner_name, c.planner_email, c.committed_at, c.script_hash
813             ORDER BY c.committed_at ASC
814             }, { Slice => {} }, $self->plan->project, $change->id) };
815             }
816              
817             sub load_change {
818 0     0 1 0 my ( $self, $change_id ) = @_;
819 0         0 my $tscol = sprintf $self->_ts2char_format, 'c.planned_at';
820 0         0 my $tagcol = sprintf $self->_listagg_format, 't.tag';
821 0   0     0 my $change = $self->dbh->selectrow_hashref(qq{
822             SELECT c.change_id AS id, c.change AS name, c.project, c.note,
823             $tscol AS "timestamp", c.planner_name, c.planner_email,
824             $tagcol AS tags, c.script_hash
825             FROM changes c
826             LEFT JOIN tags t ON c.change_id = t.change_id
827             WHERE c.change_id = ?
828             GROUP BY c.change_id, c.change, c.project, c.note, c.planned_at,
829             c.planner_name, c.planner_email, c.script_hash
830             }, undef, $change_id) || return undef;
831 0         0 $change->{timestamp} = _dt $change->{timestamp};
832 0 0       0 unless (ref $change->{tags}) {
833 0 0       0 $change->{tags} = $change->{tags} ? [ split / / => $change->{tags} ] : [];
834             }
835 0         0 return $change;
836             }
837              
838             sub _offset_op {
839 0     0   0 my ( $self, $offset ) = @_;
840 0 0       0 my ( $dir, $op ) = $offset > 0 ? ( 'ASC', '>' ) : ( 'DESC' , '<' );
841 0         0 return $dir, $op, 'OFFSET ' . (abs($offset) - 1);
842             }
843              
844             sub change_id_offset_from_id {
845 0     0 1 0 my ( $self, $change_id, $offset ) = @_;
846              
847             # Just return the ID if there is no offset.
848 0 0       0 return $change_id unless $offset;
849              
850 0         0 my ($dir, $op, $offset_expr) = $self->_offset_op($offset);
851 0         0 return $self->dbh->selectcol_arrayref(qq{
852             SELECT change_id
853             FROM changes
854             WHERE project = ?
855             AND committed_at $op (
856             SELECT committed_at FROM changes WHERE change_id = ?
857             )
858             ORDER BY committed_at $dir
859             LIMIT 1 $offset_expr
860             }, undef, $self->plan->project, $change_id)->[0];
861             }
862              
863             sub change_offset_from_id {
864 0     0 1 0 my ( $self, $change_id, $offset ) = @_;
865              
866             # Just return the object if there is no offset.
867 0 0       0 return $self->load_change($change_id) unless $offset;
868              
869             # Are we offset forwards or backwards?
870 0         0 my ($dir, $op, $offset_expr) = $self->_offset_op($offset);
871 0         0 my $tscol = sprintf $self->_ts2char_format, 'c.planned_at';
872 0         0 my $tagcol = sprintf $self->_listagg_format, 't.tag';
873              
874 0   0     0 my $change = $self->dbh->selectrow_hashref(qq{
875             SELECT c.change_id AS id, c.change AS name, c.project, c.note,
876             $tscol AS "timestamp", c.planner_name, c.planner_email,
877             $tagcol AS tags, c.script_hash
878             FROM changes c
879             LEFT JOIN tags t ON c.change_id = t.change_id
880             WHERE c.project = ?
881             AND c.committed_at $op (
882             SELECT committed_at FROM changes WHERE change_id = ?
883             )
884             GROUP BY c.change_id, c.change, c.project, c.note, c.planned_at,
885             c.planner_name, c.planner_email, c.committed_at, c.script_hash
886             ORDER BY c.committed_at $dir
887             LIMIT 1 $offset_expr
888             }, undef, $self->plan->project, $change_id) || return undef;
889 0         0 $change->{timestamp} = _dt $change->{timestamp};
890 0 0       0 unless (ref $change->{tags}) {
891 0 0       0 $change->{tags} = $change->{tags} ? [ split / / => $change->{tags} ] : [];
892             }
893 0         0 return $change;
894             }
895              
896             sub _cid_head {
897 0     0   0 my ($self, $project, $change) = @_;
898 0         0 return $self->dbh->selectcol_arrayref(q{
899             SELECT change_id
900             FROM changes
901             WHERE project = ?
902             AND changes.change = ?
903             ORDER BY committed_at DESC
904             LIMIT 1
905             }, undef, $project, $change)->[0];
906             }
907              
908             sub change_id_for {
909 1     1 1 10 my ( $self, %p) = @_;
910 1         3 my $dbh = $self->dbh;
911              
912 1 50       7 if ( my $cid = $p{change_id} ) {
913             # Find by ID.
914 0         0 return $dbh->selectcol_arrayref(q{
915             SELECT change_id
916             FROM changes
917             WHERE change_id = ?
918             }, undef, $cid)->[0];
919             }
920              
921 1   33     4 my $project = $p{project} || $self->plan->project;
922 1 50       4 if ( my $change = $p{change} ) {
923 0 0       0 if ( my $tag = $p{tag} ) {
924             # There is nothing before the first tag.
925 0 0       0 return undef if $tag eq 'ROOT';
926              
927             # Find closest to the end for @HEAD.
928 0 0       0 return $self->_cid_head($project, $change) if $tag eq 'HEAD';
929              
930             # Find by change name and following tag.
931 0 0       0 my $limit = $self->_can_limit ? "\n LIMIT 1" : '';
932 0         0 return $dbh->selectcol_arrayref(qq{
933             SELECT changes.change_id
934             FROM changes
935             JOIN tags
936             ON changes.committed_at <= tags.committed_at
937             AND changes.project = tags.project
938             WHERE changes.project = ?
939             AND changes.change = ?
940             AND tags.tag = ?
941             ORDER BY changes.committed_at DESC$limit
942             }, undef, $project, $change, '@' . $tag)->[0];
943             }
944              
945             # Find earliest by change name.
946 0         0 my $ids = $dbh->selectcol_arrayref(qq{
947             SELECT change_id
948             FROM changes
949             WHERE project = ?
950             AND changes.change = ?
951             ORDER BY changes.committed_at ASC
952             }, undef, $project, $change);
953              
954             # Return the ID.
955 0 0       0 return $ids->[0] if $p{first};
956 0         0 return $self->_handle_lookup_index($change, $ids);
957             }
958              
959 1 50       4 if ( my $tag = $p{tag} ) {
960             # Just return the latest for @HEAD.
961 0 0       0 return $self->_cid('DESC', 0, $project) if $tag eq 'HEAD';
962              
963             # Just return the earliest for @ROOT.
964 0 0       0 return $self->_cid('ASC', 0, $project) if $tag eq 'ROOT';
965              
966             # Find by tag name.
967 0         0 return $dbh->selectcol_arrayref(q{
968             SELECT change_id
969             FROM tags
970             WHERE project = ?
971             AND tag = ?
972             }, undef, $project, '@' . $tag)->[0];
973             }
974              
975             # We got nothin.
976 1         4 return undef;
977             }
978              
979             sub _update_script_hashes {
980 0     0     my $self = shift;
981 0           my $plan = $self->plan;
982 0           my $proj = $plan->project;
983 0           my $dbh = $self->dbh;
984 0           my $sth = $dbh->prepare(
985             'UPDATE changes SET script_hash = ? WHERE change_id = ? AND script_hash = ?'
986             );
987              
988 0           $self->begin_work;
989 0           $sth->execute($_->script_hash, $_->id, $_->id) for $plan->changes;
990 0           $dbh->do(q{
991             UPDATE changes SET script_hash = NULL
992             WHERE project = ? AND script_hash = change_id
993             }, undef, $proj);
994              
995 0           $self->finish_work;
996 0           return $self;
997             }
998              
999              
1000             sub begin_work {
1001 0     0 1   my $self = shift;
1002             # Note: Engines should acquire locks to prevent concurrent Sqitch activity.
1003 0           $self->dbh->begin_work;
1004 0           return $self;
1005             }
1006              
1007             sub finish_work {
1008 0     0 1   my $self = shift;
1009 0           $self->dbh->commit;
1010 0           return $self;
1011             }
1012              
1013             sub rollback_work {
1014 0     0 1   my $self = shift;
1015 0           $self->dbh->rollback;
1016 0           return $self;
1017             }
1018              
1019             1;
1020              
1021             __END__
1022              
1023             =head1 Name
1024              
1025             App::Sqitch::Command::checkout - An engine based on the DBI
1026              
1027             =head1 Synopsis
1028              
1029             package App::Sqitch::Engine::sqlite;
1030             extends 'App::Sqitch::Engine';
1031             with 'App::Sqitch::Role::DBIEngine';
1032              
1033             =head1 Description
1034              
1035             This role encapsulates the common attributes and methods required by
1036             DBI-powered engines.
1037              
1038             =head1 Interface
1039              
1040             =head2 Instance Methods
1041              
1042             =head3 C<earliest_change_id>
1043              
1044             =head3 C<latest_change_id>
1045              
1046             =head3 C<current_state>
1047              
1048             =head3 C<current_changes>
1049              
1050             =head3 C<current_tags>
1051              
1052             =head3 C<search_events>
1053              
1054             =head3 C<registered_projects>
1055              
1056             =head3 C<register_project>
1057              
1058             =head3 C<is_deployed_change>
1059              
1060             =head3 C<are_deployed_changes>
1061              
1062             =head3 C<log_deploy_change>
1063              
1064             =head3 C<log_fail_change>
1065              
1066             =head3 C<changes_requiring_change>
1067              
1068             =head3 C<name_for_change_id>
1069              
1070             =head3 C<log_new_tags>
1071              
1072             =head3 C<log_revert_change>
1073              
1074             =head3 C<begin_work>
1075              
1076             =head3 C<finish_work>
1077              
1078             =head3 C<rollback_work>
1079              
1080             =head3 C<is_deployed_tag>
1081              
1082             =head3 C<deployed_changes>
1083              
1084             =head3 C<deployed_changes_since>
1085              
1086             =head3 C<load_change>
1087              
1088             =head3 C<change_offset_from_id>
1089              
1090             =head3 C<change_id_offset_from_id>
1091              
1092             =head3 C<change_id_for>
1093              
1094             =head3 C<registry_version>
1095              
1096             =head1 See Also
1097              
1098             =over
1099              
1100             =item L<App::Sqitch::Engine::pg>
1101              
1102             The PostgreSQL engine.
1103              
1104             =item L<App::Sqitch::Engine::sqlite>
1105              
1106             The SQLite engine.
1107              
1108             =item L<App::Sqitch::Engine::oracle>
1109              
1110             The Oracle engine.
1111              
1112             =item L<App::Sqitch::Engine::mysql>
1113              
1114             The MySQL engine.
1115              
1116             =item L<App::Sqitch::Engine::vertica>
1117              
1118             The Vertica engine.
1119              
1120             =item L<App::Sqitch::Engine::exasol>
1121              
1122             The Exasol engine.
1123              
1124             =item L<App::Sqitch::Engine::snowflake>
1125              
1126             The Snowflake engine.
1127              
1128             =back
1129              
1130             =head1 Author
1131              
1132             David E. Wheeler <david@justatheory.com>
1133              
1134             =head1 License
1135              
1136             Copyright (c) 2012-2023 iovation Inc., David E. Wheeler
1137              
1138             Permission is hereby granted, free of charge, to any person obtaining a copy
1139             of this software and associated documentation files (the "Software"), to deal
1140             in the Software without restriction, including without limitation the rights
1141             to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
1142             copies of the Software, and to permit persons to whom the Software is
1143             furnished to do so, subject to the following conditions:
1144              
1145             The above copyright notice and this permission notice shall be included in all
1146             copies or substantial portions of the Software.
1147              
1148             THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
1149             IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
1150             FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
1151             AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
1152             LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
1153             OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
1154             SOFTWARE.
1155              
1156             =cut