File Coverage

blib/lib/App/Sqitch/Plan.pm
Criterion Covered Total %
statement 376 376 100.0
branch 172 186 92.4
condition 49 59 83.0
subroutine 61 61 100.0
pod 29 29 100.0
total 687 711 96.6


line stmt bran cond sub pod time code
1              
2             use 5.010;
3 50     50   993 use utf8;
  50         165  
4 50     50   273 use App::Sqitch::Plan::Tag;
  50         91  
  50         300  
5 50     50   18608 use App::Sqitch::Plan::Change;
  50         149  
  50         1647  
6 50     50   23031 use App::Sqitch::Plan::Blank;
  50         170  
  50         1714  
7 50     50   20340 use App::Sqitch::Plan::Pragma;
  50         151  
  50         1561  
8 50     50   19580 use App::Sqitch::Plan::Depend;
  50         149  
  50         1593  
9 50     50   340 use Path::Class;
  50         100  
  50         1047  
10 50     50   232 use App::Sqitch::Plan::ChangeList;
  50         101  
  50         2592  
11 50     50   21528 use App::Sqitch::Plan::LineList;
  50         114  
  50         1602  
12 50     50   18765 use Locale::TextDomain qw(App-Sqitch);
  50         111  
  50         1602  
13 50     50   300 use App::Sqitch::X qw(hurl);
  50         90  
  50         300  
14 50     50   7240 use List::MoreUtils qw(uniq any);
  50         96  
  50         382  
15 50     50   11200 use namespace::autoclean;
  50         96  
  50         426  
16 50     50   50103 use Moo;
  50         99  
  50         356  
17 50     50   3046 use App::Sqitch::Types qw(Str Int HashRef ChangeList LineList Maybe Sqitch URI File Target);
  50         87  
  50         275  
18 50     50   17348 use constant SYNTAX_VERSION => '1.0.0';
  50         103  
  50         335  
19 50     50   75776  
  50         101  
  50         269799  
20             our $VERSION = 'v1.3.0'; # VERSION
21              
22             # Like [:punct:], but excluding _. Copied from perlrecharclass.
23             my $punct = q{-!"#$%&'()*+,./:;<=>?@[\\]^`{|}~};
24             my $name_re = qr{
25             (?![$punct]) # first character isn't punctuation
26             (?: # start non-capturing group, repeated once or more ...
27             (?! # negative look ahead for...
28             [~/=%^] # symbolic reference punctuation
29             [[:digit:]]+ # digits
30             (?:$|[[:blank:]]) # eol or blank
31             ) # ...
32             [^[:blank:]:@#] # match a valid character
33             )+ # ... end non-capturing group
34             (?<![$punct])\b # last character isn't punctuation
35             }x;
36              
37             my %reserved = map { $_ => undef } qw(ROOT HEAD);
38              
39              
40 442     442 1 4857 has sqitch => (
41             is => 'ro',
42             isa => Sqitch,
43             required => 1,
44             weak_ref => 1,
45             );
46              
47             has target => (
48             is => 'ro',
49             isa => Target,
50             required => 1,
51             weak_ref => 1,
52             );
53              
54             has file => (
55             is => 'ro',
56             isa => File,
57             lazy => 1,
58             default => sub {
59             shift->target->plan_file
60             },
61             );
62              
63             has _plan => (
64             is => 'rw',
65             isa => HashRef,
66             builder => 'load',
67             init_arg => 'plan',
68             lazy => 1,
69             required => 1,
70             );
71              
72             has _changes => (
73             is => 'ro',
74             isa => ChangeList,
75             lazy => 1,
76             default => sub {
77             App::Sqitch::Plan::ChangeList->new(@{ shift->_plan->{changes} }),
78             },
79             );
80              
81             has _lines => (
82             is => 'ro',
83             isa => LineList,
84             lazy => 1,
85             default => sub {
86             App::Sqitch::Plan::LineList->new(@{ shift->_plan->{lines} }),
87             },
88             );
89              
90             has position => (
91             is => 'rw',
92             isa => Int,
93             default => -1,
94             );
95              
96             has project => (
97             is => 'ro',
98             isa => Str,
99             lazy => 1,
100             default => sub {
101             shift->_plan->{pragmas}{project};
102             }
103             );
104              
105             has uri => (
106             is => 'ro',
107             isa => Maybe[URI],
108             lazy => 1,
109             default => sub {
110             my $uri = shift->_plan->{pragmas}{uri} || return;
111             require URI;
112             'URI'->new($uri);
113             }
114             );
115              
116             my ( $self, $data ) = @_;
117             open my $fh, '<:utf8_strict', \$data;
118             $self->_plan( $self->load($fh) );
119 8     8 1 1446 return $self;
120 8     1   139 }
  1     1   5  
  1         3  
  1         8  
  1         716  
  1         3  
  1         4  
121 8         721  
122 8         231 my $self = shift;
123             my $file = $self->file;
124             my $fh = shift || do {
125             hurl plan => __x('Plan file {file} does not exist', file => $file)
126 277     277 1 56756 unless -e $file;
127 277         4075 hurl plan => __x('Plan file {file} is not a regular file', file => $file)
128 277   66     33087 unless -f $file;
129             $file->open('<:utf8_strict') or hurl io => __x(
130             'Cannot open {file}: {error}',
131             file => $file,
132             error => $!
133             );
134             };
135              
136             return $self->_parse($file, $fh);
137             }
138              
139             my ( $self, $file, $fh ) = @_;
140 268         60057  
141             my @lines; # List of lines.
142             my @changes; # List of changes.
143             my @curr_changes; # List of changes since last tag.
144 347     347   751767 my %line_no_for; # Maps tags and changes to line numbers.
145             my %change_named; # Maps change names to change objects.
146 347         2806 my %tag_changes; # Maps changes in current tag section to line numbers.
147             my %pragmas; # Maps pragma names to values.
148 347         0 my $seen_version; # Have we seen a version pragma?
149 347         0 my $prev_tag; # Last seen tag.
150 347         0 my $prev_change; # Last seen change.
151 347         0  
152 347         0 # Regex to match timestamps.
153 347         0 my $ts_re = qr/
154 347         0 (?<yr>[[:digit:]]{4}) # year
155 347         0 - # dash
156             (?<mo>[[:digit:]]{2}) # month
157             - # dash
158 347         1893 (?<dy>[[:digit:]]{2}) # day
159             T # T
160             (?<hr>[[:digit:]]{2}) # hour
161             : # colon
162             (?<mi>[[:digit:]]{2}) # minute
163             : # colon
164             (?<sc>[[:digit:]]{2}) # second
165             Z # Zulu time
166             /x;
167              
168             my $planner_re = qr/
169             (?<planner_name>[^<]+) # name
170             [[:blank:]]+ # blanks
171             <(?<planner_email>[^>]+)> # email
172             /x;
173 347         981  
174             # Use for raising syntax error exceptions.
175             my $raise_syntax_error = sub {
176             hurl parse => __x(
177             'Syntax error in {file} at line {lineno}: {error}',
178             file => $file,
179             lineno => $fh->input_line_number,
180             error => shift
181 46     46   3629 );
182             };
183              
184             # First, find pragmas.
185             HEADER: while ( my $line = $fh->getline ) {
186             $line =~ s/\r?\n\z//;
187 347         1828  
188             # Grab blank lines first.
189             if ($line =~ /\A(?<lspace>[[:blank:]]*)(?:#[[:blank:]]*(?<note>.+)|$)/) {
190 347         8961 my $line = App::Sqitch::Plan::Blank->new( plan => $self, %+ );
191 818         30813 push @lines => $line;
192             last HEADER if @lines && !$line->note;
193             next HEADER;
194 818 100       3424 }
195 376         8732  
196 376         52673 # Grab inline note.
197 376 100 66     8544 $line =~ s/(?<rspace>[[:blank:]]*)(?:[#][[:blank:]]*(?<note>.*))?$//;
198 42         894 my %params = %+;
199              
200             $raise_syntax_error->(
201             __ 'Invalid pragma; a blank line must come between pragmas and changes'
202 442         3804 ) unless $line =~ /
203 442         5668 \A # Beginning of line
204             (?<lspace>[[:blank:]]*)? # Optional leading space
205 442 50       8914 [%] # Required %
206             (?<hspace>[[:blank:]]*)? # Optional space
207             (?<name> # followed by name consisting of...
208             [^$punct] # not punct
209             (?: # followed by...
210             [^[:blank:]=]*? # any number non-blank, non-=
211             [^$punct[:blank:]] # one not blank or punct
212             )? # ... optionally
213             ) # ... required
214             (?: # followed by value consisting of...
215             (?<lopspace>[[:blank:]]*) # Optional blanks
216             (?<operator>=) # Required =
217             (?<ropspace>[[:blank:]]*) # Optional blanks
218             (?<value>.+) # String value
219             )? # ... optionally
220             \z # end of line
221             /x;
222              
223             # XXX Die if the pragma is a dupe?
224              
225             if ($+{name} eq 'syntax-version') {
226             # Set explicit version in case we write it out later. In future
227             # releases, may change parsers depending on the version.
228             $pragmas{syntax_version} = $params{value} = SYNTAX_VERSION;
229             } elsif ($+{name} eq 'project') {
230 442 100       3956 my $proj = $+{value};
    100          
231             $raise_syntax_error->(__x(
232             qq{invalid project name "{project}": project names must not }
233 90         346 . 'begin with punctuation, contain "@", ":", "#", or blanks, or end in '
234             . 'punctuation or digits following punctuation',
235 345         1386 project => $proj,
236 345 100       5039 )) unless $proj =~ /\A$name_re\z/;
237             $pragmas{project} = $proj;
238             } else {
239             $pragmas{ $+{name} } = $+{value} // 1;
240             }
241              
242 334         1109 push @lines => App::Sqitch::Plan::Pragma->new(
243             plan => $self,
244 7   100     53 %+,
245             %params
246             );
247 431         13411 next HEADER;
248             }
249              
250             # We should have a version pragma.
251             unless ( $pragmas{syntax_version} ) {
252 431         85865 unshift @lines => $self->_version_line;
253             $pragmas{syntax_version} = SYNTAX_VERSION;
254             }
255              
256 336 100       3283 # Should have valid project pragma.
257 246         899 hurl parse => __x(
258 246         36467 'Missing %project pragma in {file}',
259             file => $file,
260             ) unless $pragmas{project};
261              
262             LINE: while ( my $line = $fh->getline ) {
263             $line =~ s/\r?\n\z//;
264              
265 336 100       1006 # Grab blank lines first.
266             if ($line =~ /\A(?<lspace>[[:blank:]]*)(?:#[[:blank:]]*(?<note>.+)|$)/) {
267 334         5888 my $line = App::Sqitch::Plan::Blank->new( plan => $self, %+ );
268 1609         39288 push @lines => $line;
269             next LINE;
270             }
271 1609 100       5613  
272 266         5353 # Grab inline note.
273 266         32529 $line =~ s/(?<rspace>[[:blank:]]*)(?:[#][[:blank:]]*(?<note>.*))?$//;
274 266         4866 my %params = %+;
275              
276             # Is it a tag or a change?
277             my $type = $line =~ /^[[:blank:]]*[@]/ ? 'tag' : 'change';
278 1343         22674 $line =~ /
279 1343         11246 ^ # Beginning of line
280             (?<lspace>[[:blank:]]*)? # Optional leading space
281              
282 1343 100       5957 (?: # followed by...
283 1343         27566 [@] # @ for tag
284             | # ...or...
285             (?<lopspace>[[:blank:]]*) # Optional blanks
286             (?<operator>[+-]) # Required + or -
287             (?<ropspace>[[:blank:]]*) # Optional blanks
288             )? # ... optionally
289              
290             (?<name>$name_re) # followed by name
291             (?<pspace>[[:blank:]]+)? # blanks
292              
293             (?: # followed by...
294             [[](?<dependencies>[^]]+)[]] # dependencies
295             [[:blank:]]* # blanks
296             )? # ... optionally
297              
298             (?: # followed by...
299             $ts_re # timestamp
300             [[:blank:]]* # blanks
301             )? # ... optionally
302              
303             (?: # followed by
304             $planner_re # planner
305             )? # ... optionally
306             $ # end of line
307             /x;
308              
309             %params = ( %params, %+ );
310              
311             # Raise errors for missing data.
312             $raise_syntax_error->(__(
313             qq{Invalid name; names must not begin with punctuation, }
314 1343         34230 . 'contain "@", ":", "#", or blanks, or end in punctuation or digits following punctuation',
315             )) if !$params{name}
316             || (!$params{yr} && $line =~ $ts_re);
317              
318             $raise_syntax_error->(__ 'Missing timestamp and planner name and email')
319             unless $params{yr} || $params{planner_name};
320             $raise_syntax_error->(__ 'Missing timestamp') unless $params{yr};
321 1343 100 100     9341  
      100        
322             $raise_syntax_error->(__ 'Missing planner name and email')
323             unless $params{planner_name};
324 1320 100 100     2607  
325 1319 100       2520 # It must not be a reserved name.
326             $raise_syntax_error->(__x(
327             '"{name}" is a reserved name',
328 1318 100       2126 name => ($type eq 'tag' ? '@' : '') . $params{name},
329             )) if exists $reserved{ $params{name} };
330              
331             # It must not look like a SHA1 hash.
332             $raise_syntax_error->(__x(
333             '"{name}" is invalid because it could be confused with a SHA1 ID',
334 1317 50       3042 name => $params{name},
    100          
335             )) if $params{name} =~ /^[0-9a-f]{40}/;
336              
337             # Assemble the timestamp.
338             require App::Sqitch::DateTime;
339             $params{timestamp} = App::Sqitch::DateTime->new(
340 1315 100       2416 year => delete $params{yr},
341             month => delete $params{mo},
342             day => delete $params{dy},
343 1314         14479 hour => delete $params{hr},
344             minute => delete $params{mi},
345             second => delete $params{sc},
346             time_zone => 'UTC',
347             );
348              
349             if ($type eq 'tag') {
350             # Fail if no changes.
351 1314         7249 unless ($prev_change) {
352             $raise_syntax_error->(__x(
353             'Tag "{tag}" declared without a preceding change',
354 1314 100       414856 tag => $params{name},
355             ));
356 449 100       1190 }
357              
358             # Fail on duplicate tag.
359             my $key = '@' . $params{name};
360 1         5 if ( my $at = $line_no_for{$key} ) {
361             $raise_syntax_error->(__x(
362             'Tag "{tag}" duplicates earlier declaration on line {line}',
363             tag => $params{name},
364 448         1186 line => $at,
365 448 100       1285 ));
366             }
367              
368             # Fail on dependencies.
369 1         6 $raise_syntax_error->(__x(
370             __ 'Tags may not specify dependencies'
371             )) if $params{dependencies};
372              
373             if (@curr_changes) {
374             # Sort all changes up to this tag by their dependencies.
375             push @changes => $self->check_changes(
376 447 100       979 $pragmas{project},
377             \%line_no_for,
378 446 100       914 @curr_changes,
379             );
380             @curr_changes = ();
381             }
382 376         1439  
383             # Create the tag and associate it with the previous change.
384             $prev_tag = App::Sqitch::Plan::Tag->new(
385 376         858 plan => $self,
386             change => $prev_change,
387             %params,
388             );
389 446         9989  
390             # Keep track of everything and clean up.
391             $prev_change->add_tag($prev_tag);
392             push @lines => $prev_tag;
393             %line_no_for = (%line_no_for, %tag_changes, $key => $fh->input_line_number);
394             %tag_changes = ();
395             } else {
396 446         38579 # Fail on duplicate change since last tag.
397 446         8214 if ( my $at = $tag_changes{ $params{name} } ) {
398 446         2016 $raise_syntax_error->(__x(
399 446         16381 'Change "{change}" duplicates earlier declaration on line {line}',
400             change => $params{name},
401             line => $at,
402 865 100       2631 ));
403             }
404              
405             # Got dependencies?
406 1         6 if (my $deps = $params{dependencies}) {
407             my (@req, @con, %seen_dep);
408             for my $depstring (split /[[:blank:]]+/, $deps) {
409             my $dep_params = App::Sqitch::Plan::Depend->parse(
410             $depstring,
411 864 100       1981 ) or $raise_syntax_error->(__x(
412 214         366 '"{dep}" is not a valid dependency specification',
413 214         1055 dep => $depstring,
414 307 100       1407 ));
415             my $dep = App::Sqitch::Plan::Depend->new(
416             plan => $self,
417             %{ $dep_params },
418             );
419             # Prevent dupes.
420             $raise_syntax_error->(
421             __x( 'Duplicate dependency "{dep}"', dep => $depstring ),
422 306         854 ) if $seen_dep{$depstring}++;
  306         5669  
423             if ($dep->conflicts) {
424             push @con => $dep;
425             } else {
426             push @req => $dep;
427 306 100       29713 }
428 305 100       1010 }
429 73         253 $params{requires} = \@req;
430             $params{conflicts} = \@con;
431 232         732 }
432              
433             $tag_changes{ $params{name} } = $fh->input_line_number;
434 212         510 push @curr_changes => $prev_change = App::Sqitch::Plan::Change->new(
435 212         464 plan => $self,
436             ( $prev_tag ? ( since_tag => $prev_tag ) : () ),
437             ( $prev_change ? ( parent => $prev_change ) : () ),
438 862         2918 %params,
439 862 100       35848 );
    100          
440             push @lines => $prev_change;
441              
442             if (my $duped = $change_named{ $params{name} }) {
443             # Get rework tags by change in reverse order to reworked change.
444             my @rework_tags;
445 862         90939 for (my $i = $#changes; $changes[$i] ne $duped; $i--) {
446             push @rework_tags => $changes[$i]->tags;
447 862 100       2621 }
448             # Add list of rework tags to the reworked change.
449 91         159 $duped->add_rework_tags(@rework_tags, $duped->tags);
450 91         466 }
451 39         261 $change_named{ $params{name} } = $prev_change;
452             }
453             }
454 91         679  
455             # Sort and store any remaining changes.
456 862         19085 push @changes => $self->check_changes(
457             $pragmas{project},
458             \%line_no_for,
459             @curr_changes,
460             ) if @curr_changes;
461              
462             return {
463 299 100       11187 changes => \@changes,
464             lines => \@lines,
465             pragmas => \%pragmas,
466             };
467             }
468 299         13676  
469             App::Sqitch::Plan::Pragma->new(
470             plan => shift,
471             name => 'syntax-version',
472             operator => '=',
473             value => SYNTAX_VERSION,
474             );
475 246     246   3818 }
476              
477             my ( $self, $proj ) = ( shift, shift );
478             my $seen = ref $_[0] eq 'HASH' ? shift : {};
479              
480             my %position;
481             my @invalid;
482              
483             my $i = 0;
484 467     467 1 1406 for my $change (@_) {
485 467 100       1262 my @bad;
486              
487 467         734 # XXX Ignoring conflicts for now.
488             for my $dep ( $change->requires ) {
489             # Ignore dependencies on other projects.
490 467         597 if ($dep->got_project) {
491 467         950 # Skip if parsed project name different from current project.
492 843         1001 next if $dep->project ne $proj;
493             } else {
494             # Skip if an ID was passed, is it could be internal or external.
495 843         2170 next if $dep->got_id;
496             }
497 249 100       1173 my $key = $dep->key_name;
498              
499 21 100       354 # Skip it if it's a change from an earlier tag.
500             if ($key =~ /.@/) {
501             # Need to look it up before the tag.
502 228 50       543 my ( $change, $tag ) = split /@/ => $key, 2;
503             if ( my $tag_at = $seen->{"\@$tag"} ) {
504 248         714 if ( my $change_at = $seen->{$change}) {
505             next if $change_at < $tag_at;
506             }
507 248 100       784 }
508             } else {
509 74         359 # Skip it if we've already seen it in the plan.
510 74 50       307 next if exists $seen->{$key} || $position{$key};
511 74 50       201 }
512 74 100       226  
513             # Hrm, unknown dependency.
514             push @bad, $key;
515             }
516             $position{$change->name} = ++$i;
517 174 100 100     662 push @invalid, [ $change->name => \@bad ] if @bad;
518             }
519              
520              
521 12         27 # Nothing bad, then go!
522             return @_ unless @invalid;
523 843         2939  
524 843 100       1833 # Build up all of the error messages.
525             my @errors;
526             for my $bad (@invalid) {
527             my $change = $bad->[0];
528             my $max_delta = 0;
529 467 100       1774 for my $dep (@{ $bad->[1] }) {
530             if ($change eq $dep) {
531             push @errors => __x(
532 9         17 'Change "{change}" cannot require itself',
533 9         13 change => $change,
534 10         132 );
535 10         12 } elsif (my $pos = $position{ $dep }) {
536 10         14 my $delta = $pos - $position{$change};
  10         19  
537 12 100       227 $max_delta = $delta if $delta > $max_delta;
    100          
538 1         4 push @errors => __xn(
539             'Change "{change}" planned {num} change before required change "{required}"',
540             'Change "{change}" planned {num} changes before required change "{required}"',
541             $delta,
542             change => $change,
543 8         13 required => $dep,
544 8 100       15 num => $delta,
545 8         21 );
546             } else {
547             push @errors => __x(
548             'Unknown change "{required}" required by change "{change}"',
549             required => $dep,
550             change => $change,
551             );
552             }
553             }
554 3         9 if ($max_delta) {
555             # Suggest that the change be moved.
556             # XXX Potentially offer to move it and rewrite the plan.
557             $errors[-1] .= "\n " . __xn(
558             'HINT: move "{change}" down {num} line in {plan}',
559             'HINT: move "{change}" down {num} lines in {plan}',
560             $max_delta,
561 10 100       937 change => $change,
562             num => $max_delta,
563             plan => $self->file,
564 6         112 );
565             }
566             }
567              
568             # Throw the exception with all of the errors.
569             hurl parse => join(
570             "\n ",
571             __n(
572             'Dependency error detected:',
573             'Dependency errors detected:',
574             @errors
575             ),
576 9         596 @errors,
577             );
578             }
579              
580             my ( $self, $file ) = @_;
581             # return has higher precedence than or, so use ||.
582             return $file->open('<:utf8_strict') || hurl io => __x(
583             'Cannot open {file}: {error}',
584             file => $file,
585             error => $!,
586             );
587             }
588 6     6 1 2903  
589              
590 6   66     16 my ( $self, %p ) = @_;
591              
592             my $reverse = 0;
593             if (my $d = delete $p{direction}) {
594             $reverse = $d =~ /^ASC/i ? 0
595             : $d =~ /^DESC/i ? 1
596             : hurl 'Search direction must be either "ASC" or "DESC"';
597 1     1 1 735 }
598 58     58 1 2389  
599 37     37 1 75068 # Limit with regular expressions?
600 9     9 1 668 my @filters;
601 62     62 1 22832 if (my $regex = delete $p{planner}) {
602 123     123 1 5208 $regex = qr/$regex/;
603 134     134 1 31918 push @filters => sub { $_[0]->planner_name =~ $regex };
604 148     148 1 79564 }
605 62     62 1 10284 if (my $regex = delete $p{name}) {
606 48     48 1 782 $regex = qr/$regex/;
607 167     167 1 19828 push @filters => sub { $_[0]->name =~ $regex };
608 14     14 1 813 }
609              
610             # Match events?
611 19     19 1 13409 if (my $op = lc(delete $p{operation} || '') ) {
612             push @filters => $op eq 'deploy' ? sub { $_[0]->is_deploy }
613 19         34 : $op eq 'revert' ? sub { $_[0]->is_revert }
614 19 100       48 : hurl qq{Unknown change operation "$op"};
615 6 100       34 }
    100          
616              
617             my $changes = $self->_changes;
618             my $offset = delete $p{offset} || 0;
619             my $limit = delete $p{limit} || 0;
620              
621 18         24 hurl 'Invalid parameters passed to search_changes(): '
622 18 100       39 . join ', ', sort keys %p if %p;
623 2         24  
624 2     8   14 # If no filters, we want to return everything.
  8         62  
625             push @filters => sub { 1 } unless @filters;
626 18 100       38  
627 3         41 if ($reverse) {
628 3     12   14 # Go backwards.
  12         78  
629             my $index = $changes->count - ($offset + 1);
630             my $end_at = $limit ? $index - $limit : -1;
631             return sub {
632 18 100 100     67 while ($index > $end_at) {
633 8     8   19 my $change = $changes->change_at($index--) or return;
634 8     8   17 return $change if any { $_->($change) } @filters;
635 5 100       37 }
    100          
636             return;
637             };
638 17         357 }
639 17   100     146  
640 17   100     42 my $index = $offset - 1;
641             my $end_at = $limit ? $index + $limit : $changes->count - 1;
642 17 50       31 return sub {
643             while ($index < $end_at) {
644             my $change = $changes->change_at(++$index) or return;
645             return $change if any { $_->($change) } @filters;
646 17 100   20   49 }
  20         70  
647             return;
648 17 100       32 };
649             }
650 4         15  
651 4 100       19 my ( $self, $key ) = @_;
652             my $index = $self->index_of($key);
653 13     13   55 hurl plan => __x(
654 9 50       22 'Cannot find change "{change}" in plan',
655 9 50       38 change => $key,
  9         15  
656             ) unless defined $index;
657 4         6 $self->position($index);
658 4         25 return $self;
659             }
660              
661 13         20 my $self = shift;
662 13 100       48 $self->position(-1);
663             return $self;
664 40     40   184 }
665 47 50       104  
666 47 100       136 my $self = shift;
  47         68  
667             if ( my $next = $self->peek ) {
668 13         25 $self->position( $self->position + 1 );
669 13         91 return $next;
670             }
671             $self->position( $self->position + 1 ) if defined $self->current;
672             return undef;
673 7     7 1 605 }
674 7         14  
675 6 100       32 my $self = shift;
676             my $pos = $self->position;
677             return if $pos < 0;
678             $self->_changes->change_at( $pos );
679 5         83 }
680 5         155  
681             my $self = shift;
682             $self->_changes->change_at( $self->position + 1 );
683             }
684 30     30 1 57165  
685 30         540 shift->_changes->change_at( -1 );
686 30         706 }
687              
688             my ( $self, $code ) = @_;
689             while ( local $_ = $self->next ) {
690 151     151 1 5634 return unless $code->($_);
691 151 100       273 }
692 125         1590 }
693 125         3879  
694             my ( $self, %p ) = @_;
695 26 100       92 ( my $name = $p{name} ) =~ s/^@//;
696 26         852 $self->_is_valid(tag => $name);
697              
698             my $changes = $self->_changes;
699             my $key = "\@$name";
700 92     92 1 61312  
701 92         1201 hurl plan => __x(
702 92 100       506 'Tag "{tag}" already exists',
703 90         1106 tag => $key
704             ) if defined $changes->index_of($key);
705              
706             my $change;
707 155     155 1 732 if (my $spec = $p{change}) {
708 155         2861 $change = $changes->get($spec) or hurl plan => __x(
709             'Unknown change: "{change}"',
710             change => $spec,
711             );
712 9     9 1 1605 } else {
713             $change = $changes->last_change or hurl plan => __x(
714             'Cannot apply tag "{tag}" to a plan with no changes',
715             tag => $key
716 2     2 1 3 );
717 2         6 }
718 4 50       10  
719             my $tag = App::Sqitch::Plan::Tag->new(
720             %p,
721             plan => $self,
722             name => $name,
723 33     33 1 41337 change => $change,
724 33         101 );
725 33         95  
726             $change->add_tag($tag);
727 19         341 $changes->index_tag( $changes->index_of( $change->id ), $tag );
728 19         274  
729             # Add tag to line list, after the change and any preceding tags.
730 19 100       69 my $lines = $self->_lines;
731             $lines->insert_at( $tag, $lines->index_of($change) + $change->tags );
732             return $tag;
733             }
734              
735 18         29 my ( $self, $p ) = @_;
736 18 100       49 # Dependencies must be parsed into objects.
737 3 50       15 $p->{requires} = [ map {
738             my $p = App::Sqitch::Plan::Depend->parse($_) // hurl plan => __x(
739             '"{dep}" is not a valid dependency specification',
740             dep => $_,
741             );
742 15 50       43 App::Sqitch::Plan::Depend->new(
743             %{ $p },
744             plan => $self,
745             conflicts => 0,
746             );
747             } uniq @{ $p->{requires} } ] if $p->{requires};
748 18         365  
749             $p->{conflicts} = [ map {
750             my $p = App::Sqitch::Plan::Depend->parse("!$_") // hurl plan => __x(
751             '"{dep}" is not a valid dependency specification',
752             dep => $_,
753             );
754             App::Sqitch::Plan::Depend->new(
755 18         5266 %{ $p },
756 18         369 plan => $self,
757             conflicts => 1,
758             );
759 18         298 } uniq @{ $p->{conflicts} } ] if $p->{conflicts};
760 18         283 }
761 18         83  
762             my ( $self, %p ) = @_;
763             $self->_is_valid(change => $p{name});
764             my $changes = $self->_changes;
765 46     46   103  
766             if ( defined( my $idx = $changes->index_of( $p{name} . '@HEAD' ) ) ) {
767             my $tag_idx = $changes->index_of_last_tagged;
768 10   100     78 hurl plan => __x(
769             qq{Change "{change}" already exists in plan {file}.\n}
770             . 'Use "sqitch rework" to copy and rework it',
771             change => $p{name},
772             file => $self->file,
773 8         26 );
  8         147  
774             }
775              
776             $self->_parse_deps(\%p);
777 46 100       166 my $change = App::Sqitch::Plan::Change->new( %p, plan => $self );
  33         199  
778              
779             # Make sure dependencies are valid.
780 7   66     197 $self->_check_dependencies( $change, 'add' );
781              
782             # We good. Append a blank line if the previous change has a tag.
783             if ( $changes->count ) {
784             my $prev = $changes->change_at( $changes->count - 1 );
785 5         17 if ( $prev->tags ) {
  5         102  
786             $self->_lines->append(
787             App::Sqitch::Plan::Blank->new( plan => $self )
788             );
789 44 100       994 }
  28         103  
790             }
791              
792             # Append the change and return.
793 43     43 1 65973 $changes->append( $change );
794 43         165 $self->_lines->append( $change );
795 29         604 return $change;
796             }
797 29 100       669  
798 1         4 my ( $self, %p ) = @_;
799             my $changes = $self->_changes;
800             my $idx = $changes->index_of( $p{name} . '@HEAD') // hurl plan => __x(
801             qq{Change "{change}" does not exist in {file}.\n}
802             . 'Use "sqitch add {change}" to add it to the plan',
803 1         19 change => $p{name},
804             file => $self->file,
805             );
806              
807 28         127 my $tag_idx = $changes->index_of_last_tagged;
808 26         697 hurl plan => __x(
809             qq{Cannot rework "{change}" without an intervening tag.\n}
810             . 'Use "sqitch tag" to create a tag and try again',
811 26         8407 change => $p{name},
812             ) if !defined $tag_idx || $tag_idx < $idx;
813              
814 24 100       110 $self->_parse_deps(\%p);
815 15         48  
816 15 100       47 my ($tag) = $changes->change_at($tag_idx)->tags;
817 3         61 unshift @{ $p{requires} ||= [] } => App::Sqitch::Plan::Depend->new(
818             plan => $self,
819             change => $p{name},
820             tag => $tag->name,
821             );
822              
823             my $orig = $changes->change_at($idx);
824 24         198 my $new = App::Sqitch::Plan::Change->new( %p, plan => $self );
825 24         381  
826 24         146 # Make sure dependencies are valid.
827             $self->_check_dependencies( $new, 'rework' );
828              
829             # We good.
830 22     22 1 12022 $orig->add_rework_tags($tag);
831 22         454 $changes->append( $new );
832             $self->_lines->append( $new );
833             return $new;
834             }
835              
836 22   100     545 my ( $self, $change, $action ) = @_;
837             my $changes = $self->_changes;
838             my $project = $self->project;
839 20         119 for my $req ( $change->requires ) {
840             next if $req->project ne $project;
841             $req = $req->key_name;
842             next if defined $changes->index_of($req =~ /@/ ? $req : $req . '@HEAD');
843             my $name = $change->name;
844 20 100 100     227 if ($action eq 'add') {
845             hurl plan => __x(
846 18         98 'Cannot add change "{change}": requires unknown change "{req}"',
847             change => $name,
848 16         150 req => $req,
849 16   100     405 );
850             } else {
851             hurl plan => __x(
852 16         134 'Cannot rework change "{change}": requires unknown change "{req}"',
853             change => $name,
854             req => $req,
855 16         2185 );
856 16         320 }
857             }
858             return $self;
859 16         5073 }
860              
861             my ( $self, $type, $name ) = @_;
862 15         362 hurl plan => __x(
863 15         431 '"{name}" is a reserved name',
864 15         277 name => $name
865 15         90 ) if exists $reserved{$name};
866             hurl plan => __x(
867             '"{name}" is invalid because it could be confused with a SHA1 ID',
868             name => $name,
869 52     52   5172 ) if $name =~ /^[0-9a-f]{40}/;
870 52         907  
871 52         1030 unless ($name =~ /\A$name_re\z/) {
872 52         802 if ($type eq 'change') {
873 34 100       558 hurl plan => __x(
874 31         1150 qq{"{name}" is invalid: changes must not begin with punctuation, }
875 31 100       247 . 'contain "@", ":", "#", or blanks, or end in punctuation or digits following punctuation',
    100          
876 6         19 name => $name,
877 6 100       21 );
878 2         7 } else {
879             hurl plan => __x(
880             qq{"{name}" is invalid: tags must not begin with punctuation, }
881             . 'contain "@", ":", "#", or blanks, or end in punctuation or digits following punctuation',
882             name => $name,
883             );
884 4         15 }
885             }
886             }
887              
888             my ( $self, $file, $from, $to ) = @_;
889              
890             my @lines = $self->lines;
891 46         124  
892             if (defined $from || defined $to) {
893             my $lines = $self->_lines;
894              
895 97     97   10255 # Where are the pragmas?
896             my $head_ends_at = do {
897             my $i = 0;
898             while ( my $line = $lines[$i] ) {
899 97 100       302 last if $line->isa('App::Sqitch::Plan::Blank')
900 93 100       203 && !length $line->note;
901             ++$i;
902             }
903             $i;
904             };
905 91 100       1327  
906 33 100       99 # Where do we start with the changes?
907 11         44 my $from_idx = defined $from ? do {
908             my $change = $self->find($from // '@ROOT') // hurl plan => __x(
909             'Cannot find change {change}',
910             change => $from,
911             );
912             $lines->index_of($change);
913 22         70 } : $head_ends_at + 1;
914              
915             # Where do we end up?
916             my $to_idx = defined $to ? do {
917             my $change = $self->find( $to // '@HEAD' ) // hurl plan => __x(
918             'Cannot find change {change}',
919             change => $to,
920             );
921              
922             # Include any subsequent tags.
923 51     51 1 4055 if (my @tags = $change->tags) {
924             $change = $tags[-1];
925 51         241 }
926             $lines->index_of($change);
927 51 100 100     326 } : $#lines;
928 11         164  
929             # Collect the lines to write.
930             @lines = (
931 11         74 @lines[ 0 .. $head_ends_at ],
932 11         19 @lines[ $from_idx .. $to_idx ],
933 11         29 );
934 37 100 100     382 }
935              
936 26         72 my $fh = $file->open('>:utf8_strict') or hurl io => __x(
937             'Cannot open {file}: {error}',
938 11         74 file => $file,
939             error => $!
940             );
941             $fh->say($_->as_string) for @lines;
942 11 100       30 $fh->close or hurl io => __x(
943 9   50     33 '"Error closing {file}: {error}',
      33        
944             file => $file,
945             error => $!,
946             );
947 9         36 return $self;
948             }
949              
950             1;
951 11 100       26  
952 6   50     21  
      33        
953             =head1 Name
954              
955             App::Sqitch::Plan - Sqitch Deployment Plan
956              
957             =head1 Synopsis
958 6 100       18  
959 3         29 my $plan = App::Sqitch::Plan->new( sqitch => $sqitch );
960             while (my $change = $plan->next) {
961 6         34 say "Deploy ", $change->format_name;
962             }
963              
964             =head1 Description
965 11         42  
966             App::Sqitch::Plan provides the interface for a Sqitch plan. It parses a plan
967             file and provides an iteration interface for working with the plan.
968              
969             =head1 Interface
970              
971 51 50       198 =head2 Constants
972              
973             =head3 C<SYNTAX_VERSION>
974              
975             Returns the current version of the Sqitch plan syntax. Used for the
976 51         9361 C<%sytax-version> pragma.
977 51 50       683  
978             =head2 Class Methods
979              
980             =head3 C<name_regex>
981              
982 51         5215 die "$this has no name" unless $this =~ App::Sqitch::Plan->name_regex;
983              
984             Returns a regular expression that matches names. Note that it is not anchored,
985             so if you need to make sure that a string is a valid name and nothing else,
986             you will need to anchor it yourself, like so:
987              
988             my $name_re = App::Sqitch::Plan->name_regex;
989             die "$this is not a valid name" if $this !~ /\A$name_re\z/;
990              
991             =head2 Constructors
992              
993             =head3 C<new>
994              
995             my $plan = App::Sqitch::Plan->new( sqitch => $sqitch );
996              
997             Instantiates and returns a App::Sqitch::Plan object. Takes a single parameter:
998             an L<App::Sqitch> object.
999              
1000             =head2 Accessors
1001              
1002             =head3 C<sqitch>
1003              
1004             my $sqitch = $plan->sqitch;
1005              
1006             Returns the L<App::Sqitch> object that instantiated the plan.
1007              
1008             =head3 C<target>
1009              
1010             my $target = $plan->target
1011              
1012             Returns the L<App::Sqitch::Target> passed to the constructor.
1013              
1014             =head3 C<file>
1015              
1016             my $file = $plan->file;
1017              
1018             The file name from which to read the plan.
1019              
1020             =head3 C<position>
1021              
1022             Returns the current position of the iterator. This is an integer that's used
1023             as an index into plan. If C<next()> has not been called, or if C<reset()> has
1024             been called, the value will be -1, meaning it is outside of the plan. When
1025             C<next> returns C<undef>, the value will be the last index in the plan plus 1.
1026              
1027             =head3 C<project>
1028              
1029             my $project = $plan->project;
1030              
1031             Returns the name of the project as set via the C<%project> pragma in the plan
1032             file.
1033              
1034             =head3 C<uri>
1035              
1036             my $uri = $plan->uri;
1037              
1038             Returns the URI for the project as set via the C<%uri> pragma, which is
1039             optional. If it is not present, C<undef> will be returned.
1040              
1041             =head3 C<syntax_version>
1042              
1043             my $syntax_version = $plan->syntax_version;
1044              
1045             Returns the plan syntax version, which is always the latest version.
1046              
1047             =head2 Instance Methods
1048              
1049             =head3 C<index_of>
1050              
1051             my $index = $plan->index_of('6c2f28d125aff1deea615f8de774599acf39a7a1');
1052             my $foo_index = $plan->index_of('@foo');
1053             my $bar_index = $plan->index_of('bar');
1054             my $bar1_index = $plan->index_of('bar@alpha')
1055             my $bar2_index = $plan->index_of('bar@HEAD');
1056              
1057             Returns the index of the specified change. Returns C<undef> if no such change
1058             exists. The argument may be any one of:
1059              
1060             =over
1061              
1062             =item * An ID
1063              
1064             my $index = $plan->index_of('6c2f28d125aff1deea615f8de774599acf39a7a1');
1065              
1066             This is the SHA1 hash of a change or tag. Currently, the full 40-character hexed
1067             hash string must be specified.
1068              
1069             =item * A change name
1070              
1071             my $index = $plan->index_of('users_table');
1072              
1073             The name of a change. Will throw an exception if the named change appears more
1074             than once in the list.
1075              
1076             =item * A tag name
1077              
1078             my $index = $plan->index_of('@beta1');
1079              
1080             The name of a tag, including the leading C<@>.
1081              
1082             =item * A tag-qualified change name
1083              
1084             my $index = $plan->index_of('users_table@beta1');
1085              
1086             The named change as it was last seen in the list before the specified tag.
1087              
1088             =back
1089              
1090             =head3 C<contains>
1091              
1092             say 'Yes!' if $plan->contains('6c2f28d125aff1deea615f8de774599acf39a7a1');
1093              
1094             Like C<index_of()>, but never throws an exception, and returns true if the
1095             plan contains the specified change, and false if it does not.
1096              
1097             =head3 C<get>
1098              
1099             my $change = $plan->get('6c2f28d125aff1deea615f8de774599acf39a7a1');
1100             my $foo = $plan->get('@foo');
1101             my $bar = $plan->get('bar');
1102             my $bar1 = $plan->get('bar@alpha')
1103             my $bar2 = $plan->get('bar@HEAD');
1104              
1105             Returns the change corresponding to the specified ID or name. The argument may
1106             be in any of the formats described for C<index_of()>.
1107              
1108             =head3 C<find>
1109              
1110             my $change = $plan->find('6c2f28d125aff1deea615f8de774599acf39a7a1');
1111             my $foo = $plan->find('@foo');
1112             my $bar = $plan->find('bar');
1113             my $bar1 = $plan->find('bar@alpha')
1114             my $bar2 = $plan->find('bar@HEAD');
1115              
1116             Finds the change corresponding to the specified ID or name. The argument may be
1117             in any of the formats described for C<index_of()>. Unlike C<get()>, C<find()>
1118             will not throw an error if more than one change exists with the specified name,
1119             but will return the first instance.
1120              
1121             =head3 C<first_index_of>
1122              
1123             my $index = $plan->first_index_of($change_name);
1124             my $index = $plan->first_index_of($change_name, $change_or_tag_name);
1125              
1126             Returns the index of the first instance of the named change in the plan. If a
1127             second argument is passed, the index of the first instance of the change
1128             I<after> the index of the second argument will be returned. This is useful
1129             for getting the index of a change as it was deployed after a particular tag, for
1130             example, to get the first index of the F<foo> change since the C<@beta> tag, do
1131             this:
1132              
1133             my $index = $plan->first_index_of('foo', '@beta');
1134              
1135             You can also specify the first instance of a change after another change,
1136             including such a change at the point of a tag:
1137              
1138             my $index = $plan->first_index_of('foo', 'users_table@beta1');
1139              
1140             The second argument must unambiguously refer to a single change in the plan. As
1141             such, it should usually be a tag name or tag-qualified change name. Returns
1142             C<undef> if the change does not appear in the plan, or if it does not appear
1143             after the specified second argument change name.
1144              
1145             =head3 C<last_tagged_change>
1146              
1147             my $change = $plan->last_tagged_change;
1148              
1149             Returns the last tagged change object. Returns C<undef> if no changes have
1150             been tagged.
1151              
1152             =head3 C<change_at>
1153              
1154             my $change = $plan->change_at($index);
1155              
1156             Returns the change at the specified index.
1157              
1158             =head3 C<seek>
1159              
1160             $plan->seek('@foo');
1161             $plan->seek('bar');
1162              
1163             Move the plan position to the specified change. Dies if the change cannot be found
1164             in the plan.
1165              
1166             =head3 C<reset>
1167              
1168             $plan->reset;
1169              
1170             Resets iteration. Same as C<< $plan->position(-1) >>, but better.
1171              
1172             =head3 C<next>
1173              
1174             while (my $change = $plan->next) {
1175             say "Deploy ", $change->format_name;
1176             }
1177              
1178             Returns the next L<change|App::Sqitch::Plan::Change> in the plan. Returns C<undef>
1179             if there are no more changes.
1180              
1181             =head3 C<last>
1182              
1183             my $change = $plan->last;
1184              
1185             Returns the last change in the plan. Does not change the current position.
1186              
1187             =head3 C<current>
1188              
1189             my $change = $plan->current;
1190              
1191             Returns the same change as was last returned by C<next()>. Returns C<undef> if
1192             C<next()> has not been called or if the plan has been reset.
1193              
1194             =head3 C<peek>
1195              
1196             my $change = $plan->peek;
1197              
1198             Returns the next change in the plan without incrementing the iterator. Returns
1199             C<undef> if there are no more changes beyond the current change.
1200              
1201             =head3 C<changes>
1202              
1203             my @changes = $plan->changes;
1204              
1205             Returns all of the changes in the plan. This constitutes the entire plan.
1206              
1207             =head3 C<tags>
1208              
1209             my @tags = $plan->tags;
1210              
1211             Returns all of the tags in the plan.
1212              
1213             =head3 C<count>
1214              
1215             my $count = $plan->count;
1216              
1217             Returns the number of changes in the plan.
1218              
1219             =head3 C<lines>
1220              
1221             my @lines = $plan->lines;
1222              
1223             Returns all of the lines in the plan. This includes all the
1224             L<changes|App::Sqitch::Plan::Change>, L<tags|App::Sqitch::Plan::Tag>,
1225             L<pragmas|App::Sqitch::Plan::Pragma>, and L<blank
1226             lines|App::Sqitch::Plan::Blank>.
1227              
1228             =head3 C<do>
1229              
1230             $plan->do(sub { say $_[0]->name; return $_[0]; });
1231             $plan->do(sub { say $_->name; return $_; });
1232              
1233             Pass a code reference to this method to execute it for each change in the plan.
1234             Each change will be stored in C<$_> before executing the code reference, and
1235             will also be passed as the sole argument. If C<next()> has been called prior
1236             to the call to C<do()>, then only the remaining changes in the iterator will
1237             passed to the code reference. Iteration terminates when the code reference
1238             returns false, so be sure to have it return a true value if you want it to
1239             iterate over every change.
1240              
1241             =head3 C<search_changes>
1242              
1243             my $iter = $engine->search_changes( %params );
1244             while (my $change = $iter->()) {
1245             say '* $change->{event}ed $change->{change}";
1246             }
1247              
1248             Searches the changes in the plan returns an iterator code reference with the
1249             results. If no parameters are provided, a list of all changes will be returned
1250             from the iterator in plan order. The supported parameters are:
1251              
1252             =over
1253              
1254             =item C<event>
1255              
1256             An array of the type of event to search for. Allowed values are "deploy" and
1257             "revert".
1258              
1259             =item C<name>
1260              
1261             Limit the results to changes with names matching the specified regular
1262             expression.
1263              
1264             =item C<planner>
1265              
1266             Limit the changes to those added by planners matching the specified regular
1267             expression.
1268              
1269             =item C<limit>
1270              
1271             Limit the number of changes to the specified number.
1272              
1273             =item C<offset>
1274              
1275             Skip the specified number of events.
1276              
1277             =item C<direction>
1278              
1279             Return the results in the specified order, which must be a value matching
1280             C</^(:?a|de)sc/i> for "ascending" or "descending".
1281              
1282             =back
1283              
1284             =head3 C<write_to>
1285              
1286             $plan->write_to($file);
1287             $plan->write_to($file, $from, $to);
1288              
1289             Write the plan to the named file, including notes and white space from the
1290             original plan file. If C<from> and/or C<$to> are provided, the plan will be
1291             written only with the pragmas headers and the lines between those specified
1292             changes.
1293              
1294             =head3 C<open_script>
1295              
1296             my $file_handle = $plan->open_script( $change->deploy_file );
1297              
1298             Opens the script file passed to it and returns a file handle for reading. The
1299             script file must be encoded in UTF-8.
1300              
1301             =head3 C<load>
1302              
1303             my $plan_data = $plan->load;
1304              
1305             Loads the plan data. Called internally, not meant to be called directly, as it
1306             parses the plan file and deploy scripts every time it's called. If you want
1307             the all of the changes, call C<changes()> instead. And if you want to load an
1308             alternate plan, use C<parse()>.
1309              
1310             =head3 C<parse>
1311              
1312             $plan->parse($plan_data);
1313              
1314             Load an alternate plan by passing the complete text of the plan. The text
1315             should be UTF-8 encoded. Useful for loading a plan from a different VCS
1316             branch, for example.
1317              
1318             =head3 C<check_changes>
1319              
1320             @changes = $plan->check_changes( $project, @changes );
1321             @changes = $plan->check_changes( $project, { '@foo' => 1 }, @changes );
1322              
1323             Checks a list of changes to validate their dependencies and returns them. If
1324             the second argument is a hash reference, its keys should be previously-seen
1325             change and tag names that can be assumed to be satisfied requirements for the
1326             succeeding changes.
1327              
1328             =head3 C<tag>
1329              
1330             $plan->tag( name => 'whee' );
1331              
1332             Tags a change in the plan. Exits with a fatal error if the tag already exists
1333             in the plan or if a change cannot be found to tag. The supported parameters
1334             are:
1335              
1336             =over
1337              
1338             =item C<name>
1339              
1340             The tag name to use. Required.
1341              
1342             =item C<change>
1343              
1344             The change to be tagged, specified as a supported change specification as
1345             described in L<sqitchchanges>. Defaults to the last change in the plan.
1346              
1347             =item C<note>
1348              
1349             A brief note about the tag.
1350              
1351             =item C<planner_name>
1352              
1353             The name of the user adding the tag to the plan. Defaults to the value of the
1354             C<user.name> configuration variable.
1355              
1356             =item C<planner_email>
1357              
1358             The email address of the user adding the tag to the plan. Defaults to the
1359             value of the C<user.email> configuration variable.
1360              
1361             =back
1362              
1363             =head3 C<add>
1364              
1365             $plan->add( name => 'whatevs' );
1366             $plan->add(
1367             name => 'widgets',
1368             requires => [qw(foo bar)],
1369             conflicts => [qw(dr_evil)],
1370             );
1371              
1372             Adds a change to the plan. The supported parameters are the same as those
1373             passed to the L<App::Sqitch::Plan::Change> constructor. Exits with a fatal
1374             error if the change already exists, or if the any of the dependencies are
1375             unknown.
1376              
1377             =head3 C<rework>
1378              
1379             $plan->rework( 'whatevs' );
1380             $plan->rework( 'widgets', [qw(foo bar)], [qw(dr_evil)] );
1381              
1382             Reworks an existing change. Said change must already exist in the plan and be
1383             tagged or have a tag following it or an exception will be thrown. The previous
1384             occurrence of the change will have the suffix of the most recent tag added to
1385             it, and a new tag instance will be added to the list.
1386              
1387             =head1 Plan File
1388              
1389             A plan file describes the deployment changes to be run against a database, and
1390             is typically maintained using the L<C<add>|sqitch-add> and
1391             L<C<rework>|sqitch-rework> commands. Its contents must be plain text encoded
1392             as UTF-8. Each line of a plan file may be one of four things:
1393              
1394             =over
1395              
1396             =item *
1397              
1398             A blank line. May include any amount of white space, which will be ignored.
1399              
1400             =item * A Pragma
1401              
1402             Begins with a C<%>, followed by a pragma name, optionally followed by C<=> and
1403             a value. Currently, the only pragma recognized by Sqitch is C<syntax-version>.
1404              
1405             =item * A change.
1406              
1407             A named change change as defined in L<sqitchchanges>. A change may then also
1408             contain a space-delimited list of dependencies, which are the names of other
1409             changes or tags prefixed with a colon (C<:>) for required changes or with an
1410             exclamation point (C<!>) for conflicting changes.
1411              
1412             Changes with a leading C<-> are slated to be reverted, while changes with no
1413             character or a leading C<+> are to be deployed.
1414              
1415             =item * A tag.
1416              
1417             A named deployment tag, generally corresponding to a release name. Begins with
1418             a C<@>, followed by one or more non-blanks characters, excluding "@", ":",
1419             "#", and blanks. The first and last characters must not be punctuation
1420             characters.
1421              
1422             =item * A note.
1423              
1424             Begins with a C<#> and goes to the end of the line. Preceding white space is
1425             ignored. May appear on a line after a pragma, change, or tag.
1426              
1427             =back
1428              
1429             Here's an example of a plan file with a single deploy change and tag:
1430              
1431             %syntax-version=1.0.0
1432             +users_table
1433             @alpha
1434              
1435             There may, of course, be any number of tags and changes. Here's an expansion:
1436              
1437             %syntax-version=1.0.0
1438             +users_table
1439             +insert_user
1440             +update_user
1441             +delete_user
1442             @root
1443             @alpha
1444              
1445             Here we have four changes -- "users_table", "insert_user", "update_user", and
1446             "delete_user" -- followed by two tags: "@root" and "@alpha".
1447              
1448             Most plans will have many changes and tags. Here's a longer example with three
1449             tagged deployment points, as well as a change that is deployed and later
1450             reverted:
1451              
1452             %syntax-version=1.0.0
1453             +users_table
1454             +insert_user
1455             +update_user
1456             +delete_user
1457             +dr_evil
1458             @root
1459             @alpha
1460              
1461             +widgets_table
1462             +list_widgets
1463             @beta
1464              
1465             -dr_evil
1466             +ftw
1467             @gamma
1468              
1469             Using this plan, to deploy to the "beta" tag, all of the changes up to the
1470             "@root" and "@alpha" tags must be deployed, as must changes listed before the
1471             "@beta" tag. To then deploy to the "@gamma" tag, the "dr_evil" change must be
1472             reverted and the "ftw" change must be deployed. If you then choose to revert
1473             to "@alpha", then the "ftw" change will be reverted, the "dr_evil" change
1474             re-deployed, and the "@gamma" tag removed; then "list_widgets" must be
1475             reverted and the associated "@beta" tag removed, then the "widgets_table"
1476             change must be reverted.
1477              
1478             Changes can only be repeated if one or more tags intervene. This allows Sqitch
1479             to distinguish between them. An example:
1480              
1481             %syntax-version=1.0.0
1482             +users_table
1483             @alpha
1484              
1485             +add_widget
1486             +widgets_table
1487             @beta
1488              
1489             +add_user
1490             @gamma
1491              
1492             +widgets_created_at
1493             @delta
1494              
1495             +add_widget
1496              
1497             Note that the "add_widget" change is repeated after the "@beta" tag, and at
1498             the end. Sqitch will notice the repetition when it parses this file, and allow
1499             it, because at least one tag "@beta" appears between the instances of
1500             "add_widget". When deploying, Sqitch will fetch the instance of the deploy
1501             script as of the "@delta" tag and apply it as the first change, and then, when
1502             it gets to the last change, retrieve the current instance of the deploy
1503             script. How does it find such files? The first instances files will either be
1504             named F<add_widget@delta.sql> or (soon) findable in the VCS history as of a
1505             VCS "delta" tag.
1506              
1507             =head2 Grammar
1508              
1509             Here is the EBNF Grammar for the plan file:
1510              
1511             plan-file = { <pragma> | <change-line> | <tag-line> | <note-line> | <blank-line> }* ;
1512              
1513             blank-line = [ <blanks> ] <eol>;
1514             note-line = <note> ;
1515             change-line = <name> [ "[" { <requires> | <conflicts> } "]" ] ( <eol> | <note> ) ;
1516             tag-line = <tag> ( <eol> | <note> ) ;
1517             pragma = "%" [ <blanks> ] <name> [ <blanks> ] = [ <blanks> ] <value> ( <eol> | <note> ) ;
1518              
1519             tag = "@" <name> ;
1520             requires = <name> ;
1521             conflicts = "!" <name> ;
1522             name = <non-punct> [ [ ? non-blank and not "@", ":", or "#" characters ? ] <non-punct> ] ;
1523             non-punct = ? non-punctuation, non-blank character ? ;
1524             value = ? non-EOL or "#" characters ?
1525              
1526             note = [ <blanks> ] "#" [ <string> ] <EOL> ;
1527             eol = [ <blanks> ] <EOL> ;
1528              
1529             blanks = ? blank characters ? ;
1530             string = ? non-EOL characters ? ;
1531              
1532             And written as regular expressions:
1533              
1534             my $eol = qr/[[:blank:]]*$/
1535             my $note = qr/(?:[[:blank:]]+)?[#].+$/;
1536             my $punct = q{-!"#$%&'()*+,./:;<=>?@[\\]^`{|}~};
1537             my $name = qr/[^$punct[:blank:]](?:(?:[^[:space:]:#@]+)?[^$punct[:blank:]])?/;
1538             my $tag = qr/[@]$name/;
1539             my $requires = qr/$name/;
1540             my conflicts = qr/[!]$name/;
1541             my $tag_line = qr/^$tag(?:$note|$eol)/;
1542             my $change_line = qr/^$name(?:[[](?:$requires|$conflicts)+[]])?(?:$note|$eol)/;
1543             my $note_line = qr/^$note/;
1544             my $pragma = qr/^][[:blank:]]*[%][[:blank:]]*$name[[:blank:]]*=[[:blank:]].+?(?:$note|$eol)$/;
1545             my $blank_line = qr/^$eol/;
1546             my $plan = qr/(?:$pragma|$change_line|$tag_line|$note_line|$blank_line)+/ms;
1547              
1548             =head1 See Also
1549              
1550             =over
1551              
1552             =item L<sqitch>
1553              
1554             The Sqitch command-line client.
1555              
1556             =back
1557              
1558             =head1 Author
1559              
1560             David E. Wheeler <david@justatheory.com>
1561              
1562             =head1 License
1563              
1564             Copyright (c) 2012-2022 iovation Inc., David E. Wheeler
1565              
1566             Permission is hereby granted, free of charge, to any person obtaining a copy
1567             of this software and associated documentation files (the "Software"), to deal
1568             in the Software without restriction, including without limitation the rights
1569             to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
1570             copies of the Software, and to permit persons to whom the Software is
1571             furnished to do so, subject to the following conditions:
1572              
1573             The above copyright notice and this permission notice shall be included in all
1574             copies or substantial portions of the Software.
1575              
1576             THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
1577             IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
1578             FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
1579             AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
1580             LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
1581             OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
1582             SOFTWARE.
1583              
1584             =cut