File Coverage

blib/lib/App/Sqitch/Command/bundle.pm
Criterion Covered Total %
statement 107 107 100.0
branch 23 24 95.8
condition 23 31 74.1
subroutine 20 20 100.0
pod 6 6 100.0
total 179 188 95.2


line stmt bran cond sub pod time code
1             package App::Sqitch::Command::bundle;
2              
3 3     3   997 use 5.010;
  3         13  
4 3     3   17 use strict;
  3         23  
  3         65  
5 3     3   12 use warnings;
  3         7  
  3         70  
6 3     3   21 use utf8;
  3         10  
  3         15  
7 3     3   90 use Moo;
  3         8  
  3         28  
8 3     3   1327 use App::Sqitch::Types qw(Str Dir Maybe Bool);
  3         8  
  3         56  
9 3     3   3874 use File::Path qw(make_path);
  3         12  
  3         201  
10 3     3   21 use Path::Class;
  3         7  
  3         203  
11 3     3   22 use Locale::TextDomain qw(App-Sqitch);
  3         6  
  3         25  
12 3     3   693 use App::Sqitch::X qw(hurl);
  3         6  
  3         39  
13 3     3   2120 use File::Copy ();
  3         4964  
  3         77  
14 3     3   17 use List::Util qw(first);
  3         8  
  3         208  
15 3     3   19 use namespace::autoclean;
  3         6  
  3         40  
16              
17             extends 'App::Sqitch::Command';
18             with 'App::Sqitch::Role::ContextCommand';
19              
20             our $VERSION = 'v1.4.0'; # VERSION
21              
22             has from => (
23             is => 'ro',
24             isa => Maybe[Str],
25             );
26              
27             has to => (
28             is => 'ro',
29             isa => Maybe[Str],
30             );
31              
32             has dest_dir => (
33             is => 'ro',
34             isa => Dir,
35             lazy => 1,
36             default => sub { dir 'bundle' },
37             );
38              
39             has all => (
40             is => 'ro',
41             isa => Bool,
42             default => 0
43             );
44              
45             sub dest_top_dir {
46 21     21 1 7092 my $self = shift;
47 21         513 dir $self->dest_dir, shift->top_dir->relative;
48             }
49              
50             sub dest_dirs_for {
51 19     19 1 2605 my ($self, $target) = @_;
52 19         407 my $dest = $self->dest_dir;
53             return {
54 19         579 deploy => dir($dest, $target->deploy_dir->relative),
55             revert => dir($dest, $target->revert_dir->relative),
56             verify => dir($dest, $target->verify_dir->relative),
57             reworked_deploy => dir($dest, $target->reworked_deploy_dir->relative),
58             reworked_revert => dir($dest, $target->reworked_revert_dir->relative),
59             reworked_verify => dir($dest, $target->reworked_verify_dir->relative),
60             };
61             }
62              
63             sub options {
64             return qw(
65             dest-dir|dir=s
66             all|a!
67             from=s
68             to=s
69             );
70             }
71              
72             sub configure {
73             my ( $class, $config, $opt ) = @_;
74              
75             my %params;
76              
77             if (my $dir = $opt->{dest_dir} || $config->get(key => 'bundle.dest_dir') ) {
78             $params{dest_dir} = dir $dir;
79             }
80              
81             # Make sure we get the --all, --from and --to options passed through.
82             for my $key (qw(all from to)) {
83             $params{$key} = $opt->{$key} if exists $opt->{$key};
84             }
85              
86             return \%params;
87             }
88              
89             sub execute {
90 14     14 1 64210 my $self = shift;
91 14         156 my ($targets, $changes) = $self->parse_args(
92             all => $self->all,
93             args => \@_,
94             );
95              
96             # Warn if --to or --from is specified for more thane one target.
97 11 100 66     123 if ( @{ $targets } > 1 && ($self->from || $self->to) ) {
  11   66     88  
98 2         31 $self->sqitch->warn(__(
99             "Use of --to or --from to bundle multiple targets is not recommended.\nPass them as arguments after each target argument, instead."
100             ));
101             }
102              
103             # Die if --to or --from and changes are specified.
104 11 100 66     228 if ( @{ $changes } && ($self->from || $self->to) ) {
  11   66     53  
105 1         6 hurl bundle => __(
106             'Cannot specify both --from or --to and change arguments'
107             );
108             }
109              
110             # Time to get started!
111 10         264 $self->info(__x 'Bundling into {dir}', dir => $self->dest_dir );
112 10         2304 $self->bundle_config;
113              
114 10 100       121 if (my @fromto = grep { $_ } $self->from, $self->to) {
  20         105  
115             # One set of from/to options for all targets.
116 2         8 for my $target (@{ $targets }) {
  2         13  
117 4         42 $self->bundle_plan($target, @fromto);
118 4         38 $self->bundle_scripts($target, @fromto);
119             }
120             } else {
121             # Separate from/to options for all targets.
122 8         26 for my $target (@{ $ targets }) {
  8         23  
123 10         26 my @fromto = splice @{ $changes }, 0, 2;
  10         43  
124 10         61 $self->bundle_plan($target, @fromto);
125 10         192 $self->bundle_scripts($target, @fromto);
126             }
127             }
128              
129 10         208 return $self;
130             }
131              
132             sub _copy_if_modified {
133 131     131   36686 my ( $self, $src, $dst ) = @_;
134              
135 131 100       563 hurl bundle => __x(
136             'Cannot copy {file}: does not exist',
137             file => $src,
138             ) unless -e $src;
139              
140 130 100       6225 if (-e $dst) {
141             # Skip the file if it is up-to-date.
142 19 100       928 return $self if -M $dst <= -M $src;
143             } else {
144             # Create the directory.
145 111         6217 $self->_mkpath( $dst->dir );
146             }
147              
148 112         527 $self->debug(' ', __x(
149             "Copying {source} -> {dest}",
150             source => $src,
151             dest => $dst
152             ));
153              
154             # Stringify to work around bug in File::Copy warning on 5.10.0.
155 112 100       23329 File::Copy::copy "$src", "$dst" or hurl bundle => __x(
156             'Cannot copy "{source}" to "{dest}": {error}',
157             source => $src,
158             dest => $dst,
159             error => $!,
160             );
161 111         43607 return $self;
162             }
163              
164             sub bundle_config {
165 11     11 1 3979 my $self = shift;
166 11         67 $self->info(__ 'Writing config');
167 11         1380 my $file = $self->sqitch->config->local_file;
168 11         986 $self->_copy_if_modified( $file, $self->dest_dir->file( $file->basename ) );
169             }
170              
171             sub bundle_plan {
172 17     17 1 1265 my ($self, $target, $from, $to) = @_;
173              
174 17         98 my $dir = $self->dest_top_dir($target);
175              
176 17 100 100     8110 if (!defined $from && !defined $to) {
177 10         66 $self->info(__ 'Writing plan');
178 10         1192 my $file = $target->plan_file;
179 10         2153 return $self->_copy_if_modified(
180             $file,
181             $dir->file( $file->basename ),
182             );
183             }
184              
185 7   100     101 $self->info(__x(
      100        
186             'Writing plan from {from} to {to}',
187             from => $from // '@ROOT',
188             to => $to // '@HEAD',
189             ));
190              
191 7         1199 $self->_mkpath( $dir );
192 7         200 $target->plan->write_to(
193             $dir->file( $target->plan_file->basename ),
194             $from,
195             $to,
196             );
197             }
198              
199             sub bundle_scripts {
200 19     19 1 790 my ($self, $target, $from, $to) = @_;
201 19         514 my $plan = $target->plan;
202              
203 19   100     2183 my $from_index = $plan->index_of(
      66        
204             $from // '@ROOT'
205             ) // hurl bundle => __x(
206             'Cannot find change {change}',
207             change => $from,
208             );
209              
210 17   100     118 my $to_index = $plan->index_of(
      33        
211             $to // '@HEAD'
212             ) // hurl bundle => __x(
213             'Cannot find change {change}',
214             change => $to,
215             );
216              
217 17         106 $self->info(__ 'Writing scripts');
218 17         2098 $plan->position( $from_index );
219 17         682 my $dir_for = $self->dest_dirs_for($target);
220              
221 17         6559 while ( $plan->position <= $to_index ) {
222 56   50     572 my $change = $plan->current // last;
223 56         274 $self->info(' + ', $change->format_name_with_tags);
224 56 100       2744 my $prefix = $change->is_reworked ? 'reworked_' : '';
225 56         1312 my @path = $change->path_segments;
226 56 50       1562 if (-e ( my $file = $change->deploy_file )) {
227             $self->_copy_if_modified(
228             $file,
229 56         7854 $dir_for->{"${prefix}deploy"}->file(@path)
230             );
231             }
232 56 100       1115 if (-e ( my $file = $change->revert_file )) {
233             $self->_copy_if_modified(
234             $file,
235 44         6384 $dir_for->{"${prefix}revert"}->file(@path)
236             );
237             }
238 56 100       2590 if (-e ( my $file = $change->verify_file )) {
239             $self->_copy_if_modified(
240             $file,
241 4         517 $dir_for->{"${prefix}verify"}->file(@path)
242             );
243             }
244 56         6980 $plan->next;
245             }
246              
247 17         282 return $self;
248             }
249              
250             1;
251              
252             __END__
253              
254             =head1 Name
255              
256             App::Sqitch::Command::bundle - Bundle Sqitch changes for distribution
257              
258             =head1 Synopsis
259              
260             my $cmd = App::Sqitch::Command::bundle->new(%params);
261             $cmd->execute;
262              
263             =head1 Description
264              
265             Bundles a Sqitch project for distribution. Done by creating a new directory
266             and copying the configuration file, plan file, and change files into it.
267              
268             =head1 Interface
269              
270             =head2 Attributes
271              
272             =head3 C<from>
273              
274             Change from which to build the bundled plan.
275              
276             =head3 C<to>
277              
278             Change up to which to build the bundled plan.
279              
280             =head3 C<all>
281              
282             Boolean indicating whether or not to run the command against all plans in the
283             project.
284              
285             =head2 Instance Methods
286              
287             =head3 C<execute>
288              
289             $bundle->execute($command);
290              
291             Executes the C<bundle> command.
292              
293             =head3 C<bundle_config>
294              
295             $bundle->bundle_config;
296              
297             Copies the configuration file to the bundle directory.
298              
299             =head3 C<bundle_plan>
300              
301             $bundle->bundle_plan($target);
302              
303             Copies the plan file for the specified target to the bundle directory.
304              
305             =head3 C<bundle_scripts>
306              
307             $bundle->bundle_scripts($target);
308              
309             Copies the deploy, revert, and verify scripts for each step in the plan for
310             the specified target to the bundle directory. Files in the script directories
311             that do not correspond to changes in the plan will not be copied.
312              
313             =head3 C<dest_top_dir>
314              
315             my $top_dir = $bundle->top_dir($target);
316              
317             Returns the destination top directory for the specified target.
318              
319             =head3 C<dest_dirs_for>
320              
321             my $dirs = $bundle->dest__dirs_for($target);
322              
323             Returns a hash of change script destination directories for the specified
324             target. The keys are the types of scripts, and include:
325              
326             =over
327              
328             =item C<deploy>
329              
330             =item C<revert>
331              
332             =item C<verfiy>
333              
334             =item C<reworked_deploy>
335              
336             =item C<reworked_revert>
337              
338             =item C<reworked_verfiy>
339              
340             =back
341              
342             =head1 See Also
343              
344             =over
345              
346             =item L<sqitch-bundle>
347              
348             Documentation for the C<bundle> command to the Sqitch command-line client.
349              
350             =item L<sqitch>
351              
352             The Sqitch command-line client.
353              
354             =back
355              
356             =head1 Author
357              
358             David E. Wheeler <david@justatheory.com>
359              
360             =head1 License
361              
362             Copyright (c) 2012-2023 iovation Inc., David E. Wheeler
363              
364             Permission is hereby granted, free of charge, to any person obtaining a copy
365             of this software and associated documentation files (the "Software"), to deal
366             in the Software without restriction, including without limitation the rights
367             to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
368             copies of the Software, and to permit persons to whom the Software is
369             furnished to do so, subject to the following conditions:
370              
371             The above copyright notice and this permission notice shall be included in all
372             copies or substantial portions of the Software.
373              
374             THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
375             IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
376             FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
377             AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
378             LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
379             OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
380             SOFTWARE.
381              
382             =cut