File Coverage

blib/lib/App/Sqitch/Plan/ChangeList.pm
Criterion Covered Total %
statement 114 114 100.0
branch 46 48 95.8
condition 9 12 75.0
subroutine 26 26 100.0
pod 16 16 100.0
total 211 216 97.6


line stmt bran cond sub pod time code
1             package App::Sqitch::Plan::ChangeList;
2              
3 50     50   944 use 5.010;
  50         210  
4 50     50   286 use utf8;
  50         126  
  50         293  
5 50     50   1392 use strict;
  50         183  
  50         1222  
6 50     50   338 use List::Util;
  50         2888  
  50         3311  
7 50     50   398 use Locale::TextDomain qw(App-Sqitch);
  50         123  
  50         391  
8 50     50   10606 use App::Sqitch::X qw(hurl);
  50         2386  
  50         576  
9              
10             our $VERSION = 'v1.4.0'; # VERSION
11              
12             sub new {
13 251     251 1 15887 my $class = shift;
14 251         1734 my $self = bless {
15             list => [],
16             lookup => {},
17             last_tagged_at => undef,
18             } => $class;
19 251 100       1899 $self->append(@_) if @_;
20 251         4793 return $self;
21             }
22              
23 125     125 1 1125 sub count { scalar @{ shift->{list} } }
  125         703  
24 41     41 1 665 sub changes { @{ shift->{list} } }
  41         247  
25 11     11 1 133 sub tags { map { $_->tags } @{ shift->{list} } }
  32         216  
  11         38  
26 1     1 1 4 sub items { @{ shift->{list} } }
  1         7  
27 629     629 1 9929 sub change_at { shift->{list}[shift] }
28 21     21 1 515 sub last_change { return shift->{list}[ -1 ] }
29              
30             # Like [:punct:], but excluding _. Copied from perlrecharclass.
31             my $punct = q{-!"#$%&'()*+,./:;<=>?@[\\]^`{|}~};
32              
33             sub _offset($) {
34             # Look for symbolic references.
35 896 100   896   6409 if ( $_[0] =~ s{(?<![$punct])([~^])(?:(\1)|(\d+))?\z}{} ) {
36 70 100 66     499 my $offset = $3 // ($2 ? 2 : 1);
37 70 100       231 $offset *= -1 if $1 eq '^';
38 70         228 return $offset;
39             } else {
40 826         2833 return 0;
41             }
42             }
43              
44             sub index_of {
45 584     584 1 10678 my ( $self, $key ) = @_;
46              
47             # Look for non-deployed symbolic references.
48 584 100       1630 if ( my $offset = _offset $key ) {
49 43   50     105 my $idx = $self->_index_of( $key ) // return undef;
50 43         72 $idx += $offset;
51 43 100       104 return $idx < 0 ? undef : $idx > $#{ $self->{list} } ? undef : $idx;
  40 100       216  
52             } else {
53 541         1590 return $self->_index_of( $key );
54             }
55             }
56              
57             sub _index_of {
58 584     584   1236 my ( $self, $key ) = @_;
59              
60 584         2099 my ( $change, $tag ) = split /@/ => $key, 2;
61              
62 584 100       1778 if ($change eq '') {
63             # Just want the change with the associated tag.
64 160 100       889 my $idx = $self->{lookup}{'@' . $tag} or return undef;
65 121         676 return $idx->[0];
66             }
67              
68 424 100       1846 my $idx = $self->{lookup}{$change} or return undef;
69 350 100       920 if (defined $tag) {
70             # Wanted for a change as of a specific tag.
71 135 100       614 my $tag_idx = $self->{lookup}{'@' . $tag} or hurl plan => __x(
72             'Unknown tag "{tag}"',
73             tag => '@' . $tag,
74             );
75 133         281 $tag_idx = $tag_idx->[0];
76 133         240 for my $i (reverse @{ $idx }) {
  133         339  
77 171 100       901 return $i if $i <= $tag_idx;
78             }
79 3         26 return undef;
80             };
81              
82             # Just want index for a change name. Return if we have 0 or 1.
83 215 100       343 return $idx->[0] if @{ $idx } < 2;
  215         1259  
84              
85              
86             # Too many changes found. Give the user some options and die.
87 4         27 App::Sqitch->vent(__x(
88             'Change "{change}" is ambiguous. Please specify a tag-qualified change:',
89             change => $key,
90             ));
91              
92 4         924 my $list = $self->{list};
93             App::Sqitch->vent( ' * ', $list->[$_]->format_tag_qualified_name )
94 4         9 for reverse @{ $idx };
  4         28  
95              
96 4         43 hurl plan => __ 'Change lookup failed';
97             }
98              
99             sub first_index_of {
100 286     286 1 1236 my ( $self, $key, $since ) = @_;
101              
102             # Look for non-deployed symbolic references.
103 286 100       723 if ( my $offset = _offset $key ) {
104 24   50     101 my $idx = $self->_first_index_of( $key, $since ) // return undef;
105 24         47 $idx += $offset;
106 24 50       53 return $idx < 0 ? undef : $idx > $#{ $self->{list} } ? undef : $idx;
  24 50       153  
107             } else {
108 262         772 return $self->_first_index_of( $key, $since );
109             }
110             }
111              
112             sub _first_index_of {
113 286     286   678 my ( $self, $change, $since ) = @_;
114              
115             # Just return the first index if no tag.
116 286 100       1907 my $idx = $self->{lookup}{$change} or return undef;
117 154 100       743 return $idx->[0] unless defined $since;
118              
119             # Find the tag index.
120 37   100     108 my $since_index = $self->index_of($since) // hurl plan => __x(
121             'Unknown change: "{change}"',
122             change => $since,
123             );
124              
125             # Return the first change after the tag.
126 34     42   162 return List::Util::first { $_ > $since_index } @{ $idx };
  42         241  
  34         136  
127             }
128              
129             sub index_of_last_tagged {
130 30     30 1 1058 shift->{last_tagged_at};
131             }
132              
133             sub last_tagged_change {
134 23     23 1 1404 my $self = shift;
135             return defined $self->{last_tagged_at}
136 23 100       150 ? $self->{list}[ $self->{last_tagged_at} ]
137             : undef;
138             }
139              
140             sub get {
141 180     180 1 4977 my $self = shift;
142 180   100     520 my $idx = $self->index_of(@_) // return undef;
143 149         1243 return $self->{list}[ $idx ];
144             }
145              
146             sub contains {
147 177     177 1 3558 my ( $self, $name ) = @_;
148 177 100       869 return defined ( $name =~ /@/
149             ? $self->index_of($name)
150             : $self->first_index_of($name)
151             );
152             }
153              
154             sub find {
155 89     89 1 1021 my ( $self, $name ) = @_;
156 89 100       466 my $idx = $name =~ /@/
157             ? $self->index_of($name)
158             : $self->first_index_of($name);
159 89 100       390 return defined $idx ? $self->change_at($idx) : undef;
160             }
161              
162             sub append {
163 281     281 1 1534 my $self = shift;
164 281         618 my $list = $self->{list};
165 281         587 my $lookup = $self->{lookup};
166              
167 281         747 for my $change (@_) {
168 807         7433 push @{ $list } => $change;
  807         1778  
169 807         1353 push @{ $lookup->{ $change->format_name } } => $#$list;
  807         2748  
170 807         15738 $lookup->{ $change->id } = my $pos = [$#$list];
171              
172             # Index on the tags, too.
173 807         49558 for my $tag ($change->tags) {
174 400         4044 $lookup->{ $tag->format_name } = $pos;
175 400         7088 $lookup->{ $tag->id } = $pos;
176 400         23764 $self->{last_tagged_at} = $#$list;
177             }
178             }
179              
180 281         4394 $lookup->{'HEAD'} = $lookup->{'@HEAD'} = [$#$list];
181 281         1073 $lookup->{'ROOT'} = $lookup->{'@ROOT'} = [0];
182              
183 281         647 return $self;
184             }
185              
186             sub index_tag {
187 19     19 1 79 my ( $self, $index, $tag ) = @_;
188 19         43 my $list = $self->{list};
189 19         44 my $lookup = $self->{lookup};
190 19         43 my $pos = [$index];
191 19         391 $lookup->{ $tag->id } = $pos;
192 19         1294 $lookup->{ $tag->format_name } = $pos;
193 19 100       37 $self->{last_tagged_at} = $index if $index == $#{ $self->{list} };
  19         96  
194 19         57 return $self;
195             }
196              
197             1;
198              
199             __END__
200              
201             =head1 Name
202              
203             App::Sqitch::Plan::ChangeList - Sqitch deployment plan change list
204              
205             =head1 Synopsis
206              
207             my $list = App::Sqitch::Plan::ChangeList->new(
208             $add_roles,
209             $add_users,
210             $insert_user,
211             $insert_user2,
212             );
213              
214             my @changes = $list->changes;
215             my $add_users = $list->change_at(1);
216             my $add_users = $list->get('add_users');
217              
218             my $insert_user1 = $list->get('insert_user@alpha');
219             my $insert_user2 = $list->get('insert_user');
220              
221             =head1 Description
222              
223             This module is used internally by L<App::Sqitch::Plan> to manage plan changes.
224             It's modeled on L<Array::AsHash> and L<Hash::MultiValue>, but makes allowances
225             for finding changes relative to tags.
226              
227             =head1 Interface
228              
229             =head2 Constructors
230              
231             =head3 C<new>
232              
233             my $plan = App::Sqitch::Plan::ChangeList->new( @changes );
234              
235             Instantiates and returns a App::Sqitch::Plan::ChangeList object with the list of
236             changes. Each change should be a L<App::Sqitch::Plan::Change> object. Order will be
237             preserved but the location of each change will be indexed by its name and ID, as
238             well as the names and IDs of any associated tags.
239              
240             =head2 Instance Methods
241              
242             =head3 C<count>
243              
244             my $count = $changelist->count;
245              
246             Returns the number of changes in the list.
247              
248             =head3 C<changes>
249              
250             my @changes = $changelist->changes;
251              
252             Returns all of the changes in the list.
253              
254             =head3 C<tags>
255              
256             my @tags = $changelist->tags;
257              
258             Returns all of the tags associated with changes in the list.
259              
260             =head3 C<items>
261              
262             my @changes = $changelist->items;
263              
264             An alias for C<changes>.
265              
266             =head3 C<change_at>
267              
268             my $change = $change_list->change_at(10);
269              
270             Returns the change at the specified index.
271              
272             =head3 C<index_of>
273              
274             my $index = $changelist->index_of($change_id);
275             my $index = $changelist->index_of($change_name);
276              
277             Returns the index of the change with the specified ID or name. The value passed
278             may be one of these forms:
279              
280             =over
281              
282             =item * An ID
283              
284             my $index = $changelist->index_of('6c2f28d125aff1deea615f8de774599acf39a7a1');
285              
286             This is the SHA1 ID of a change or tag. Currently, the full 40-character hexed
287             hash string must be specified.
288              
289             =item * A change name
290              
291             my $index = $changelist->index_of('users_table');
292              
293             The name of a change. Will throw an exception if the more than one change in the
294             list goes by that name.
295              
296             =item * A tag name
297              
298             my $index = $changelist->index_of('@beta1');
299              
300             The name of a tag, including the leading C<@>.
301              
302             =item * A tag-qualified change name
303              
304             my $index = $changelist->index_of('users_table@beta1');
305              
306             The named change as it was last seen in the list before the specified tag.
307              
308             =back
309              
310             =head3 C<first_index_of>
311              
312             my $index = $changelist->first_index_of($change_name);
313             my $index = $changelist->first_index_of($change_name, $name);
314              
315             Returns the index of the first instance of the named change in the list. If a
316             second argument is passed, the index of the first instance of the change
317             I<after> the index of the second argument will be returned. This is useful
318             for getting the index of a change as it was deployed after a particular tag, for
319             example:
320              
321             my $index = $changelist->first_index_of('foo', '@beta');
322             my $index = $changelist->first_index_of('foo', 'users_table@beta1');
323              
324             The second argument must unambiguously refer to a single change in the list. As
325             such, it should usually be a tag name or tag-qualified change name. Returns
326             C<undef> if the change does not appear in the list, or if it does not appear
327             after the specified second argument change name.
328              
329             =head3 C<last_change>
330              
331             my $change = $changelist->last_change;
332              
333             Returns the last change to be appear in the list. Returns C<undef> if the list
334             contains no changes.
335              
336             =head3 C<last_tagged_change>
337              
338             my $change = $changelist->last_tagged_change;
339              
340             Returns the last tagged change in the list. Returns C<undef> if the list
341             contains no tagged changes.
342              
343             =head3 C<index_of_last_tagged>
344              
345             my $index = $changelist->index_of_last_tagged;
346              
347             Returns the index of the last tagged change in the list. Returns C<undef> if the
348             list contains no tags.
349              
350             =head3 C<get>
351              
352             my $change = $changelist->get($id);
353             my $change = $changelist->get($change_name);
354             my $change = $changelist->get($tag_name);
355              
356             Returns the change for the specified ID or name. The name may be specified as
357             described for C<index_of()>. An exception will be thrown if more than one change
358             goes by a specified name. As such, it is best to specify it as unambiguously
359             as possible: as a tag name, a tag-qualified change name, or an ID.
360              
361             =head3 C<contains>
362              
363             say 'Yes!' if $plan->contains('6c2f28d125aff1deea615f8de774599acf39a7a1');
364              
365             Like C<index_of()>, but never throws an exception, and returns true if the
366             plan contains the specified change, and false if it does not.
367              
368             =head3 C<find>
369              
370             my $change = $changelist->find($id);
371             my $change = $changelist->find($change_name);
372             my $change = $changelist->find($tag_name);
373             my $change = $changelist->find("$change_name\@$tag_name");
374              
375             Tries to find and return a change based on the argument. If no tag is specified,
376             finds and returns the first instance of the named change. Otherwise, it returns
377             the change as of the specified tag. Unlike C<get()>, it will not throw an error
378             if more than one change exists with the specified name, but will return the
379             first instance.
380              
381             =head3 C<append>
382              
383             $changelist->append(@changes);
384              
385             Append one or more changes to the list. Does not check for duplicates, so
386             use with care.
387              
388             =head3 C<index_tag>
389              
390             $changelist->index_tag($index, $tag);
391              
392             Index the tag at the specified index. That is, the tag is assumed to be
393             associated with the change at the specified index, and so the internal look up
394             table is updated so that the change at that index can be found via the tag's
395             name and ID.
396              
397             =head1 See Also
398              
399             =over
400              
401             =item L<App::Sqitch::Plan>
402              
403             The Sqitch plan.
404              
405             =back
406              
407             =head1 Author
408              
409             David E. Wheeler <david@justatheory.com>
410              
411             =head1 License
412              
413             Copyright (c) 2012-2023 iovation Inc., David E. Wheeler
414              
415             Permission is hereby granted, free of charge, to any person obtaining a copy
416             of this software and associated documentation files (the "Software"), to deal
417             in the Software without restriction, including without limitation the rights
418             to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
419             copies of the Software, and to permit persons to whom the Software is
420             furnished to do so, subject to the following conditions:
421              
422             The above copyright notice and this permission notice shall be included in all
423             copies or substantial portions of the Software.
424              
425             THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
426             IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
427             FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
428             AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
429             LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
430             OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
431             SOFTWARE.
432              
433             =cut