File Coverage

blib/lib/App/Dest.pm
Criterion Covered Total %
statement 388 401 96.7
branch 128 172 74.4
condition 47 64 73.4
subroutine 48 48 100.0
pod 21 21 100.0
total 632 706 89.5


line stmt bran cond sub pod time code
1             package App::Dest;
2             # ABSTRACT: Deployment State Manager
3              
4 4     4   1046840 use 5.016;
  4         38  
5 4     4   816 use exact;
  4         44665  
  4         21  
6              
7 4     4   5428 use File::Basename qw( dirname basename );
  4         8  
  4         222  
8 4     4   543 use File::Copy 'copy';
  4         2075  
  4         204  
9 4     4   628 use File::Copy::Recursive qw( dircopy rcopy );
  4         3453  
  4         215  
10 4     4   1865 use File::DirCompare ();
  4         13040  
  4         92  
11 4     4   23 use File::Find 'find';
  4         8  
  4         309  
12 4     4   24 use File::Path qw( mkpath rmtree );
  4         7  
  4         209  
13 4     4   3334 use IPC::Run 'run';
  4         86007  
  4         209  
14 4     4   2800 use Path::Tiny 'path';
  4         37990  
  4         233  
15 4     4   1981 use Text::Diff ();
  4         29335  
  4         28150  
16              
17             our $VERSION = '1.30'; # VERSION
18              
19             sub init {
20 5     5 1 29441 my $self = _new( shift, 'expect_no_root_dir' );
21              
22 4 50       226 mkdir('.dest') or die "Unable to create .dest directory\n";
23 4 50       266 open( my $watch, '>', '.dest/watch' ) or die "Unable to create ~/.dest/watch file\n";
24              
25 4         19 $self = _new();
26              
27 4 50       91 if ( -f 'dest.watch' ) {
28 4 50       135 open( my $watches, '<', 'dest.watch' ) or die "Unable to read dest.watch file\n";
29              
30 4         117 my @watches = map { chomp; $_ } <$watches>;
  4         19  
  4         16  
31              
32 4         10 my @errors;
33 4         11 for my $watch (@watches) {
34             try {
35             $self->add($watch);
36             }
37 4         12 catch {
38             my $e = $_ || $@;
39             push( @errors, $watch . ': ' . $e );
40             };
41             }
42              
43             warn
44             "Created new watch list based on dest.watch file:\n" .
45 4         199 join( "\n", map { ' ' . $_ } @watches ) . "\n" .
46             (
47             (@errors)
48 4 50       20 ? "With the following errors:\n" . join( '', map { ' ' . $_ } @errors )
  0         0  
49             : ''
50             );
51             }
52              
53 4         65 return 0;
54             }
55              
56             sub add {
57 8     8 1 3482 my $self = _new(shift);
58 8 50       27 die "No directory specified; usage: dest add [directory]\n" unless @_;
59              
60 8         28 my @watches = $self->_watch_list;
61             my @adds = map {
62 8         30 my $dir = $_;
  8         17  
63 8 100       120 die "Directory specified does not exist\n" unless ( -d $dir );
64              
65 7         33 my $rel_dir = $self->_rel2root($dir);
66 7 100       1468 die "Directory $dir already added\n" if ( grep { $rel_dir eq $_ } @watches );
  2         17  
67 6         21 $rel_dir;
68             } @_;
69              
70 6 50       30 open( my $watch, '>', $self->_rel2dir('.dest/watch') ) or die "Unable to write ~/.dest/watch file\n";
71 6         81 print $watch $_, "\n" for ( sort @adds, map { $self->_rel2root($_) } @watches );
  1         4  
72 6         195 mkpath("$self->{root_dir}/.dest/$_") for (@adds);
73              
74 6         1414 return 0;
75             }
76              
77             sub rm {
78 1     1 1 855 my $self = _new(shift);
79 1 50       6 die "No directory specified; usage: dest rm [directory]\n" unless @_;
80              
81 1         4 my @watches = $self->_watch_list;
82             my @rms = map {
83 1         4 my $dir = $_;
  1         2  
84 1   50     4 $dir //= '';
85 1         4 $dir =~ s|/$||;
86              
87 1 50       2 die "Directory $dir not currently tracked\n" unless ( grep { $dir eq $_ } @watches );
  1         4  
88              
89 1         5 $self->_rel2root($dir);
90             } @_;
91              
92 1 50       169 open( my $watch_file, '>', $self->_rel2dir('.dest/watch') ) or die "Unable to write ~/.dest/watch file\n";
93 1         6 for my $watch_dir ( map { $self->_rel2root($_) } @watches ) {
  1         3  
94 1 50       195 if ( grep { $watch_dir eq $_ } @rms ) {
  1         5  
95 1         5 rmtree( $self->_rel2dir(".dest/$watch_dir") );
96             }
97             else {
98 0         0 print $watch_file $watch_dir, "\n";
99             }
100             }
101              
102 1         16 return 0;
103             }
104              
105             sub watches {
106 3     3 1 3955 my $self = _new(shift);
107              
108 3         12 my @watches = $self->_watch_list;
109 3 100       62 print join( "\n", @watches ), "\n" if @watches;
110              
111 3         21 return 0;
112             }
113              
114             sub putwatch {
115 1     1 1 713 my $self = _new(shift);
116 1         5 my ($file) = @_;
117 1 50       16 die "File specified does not exist\n" unless ( -f $file );
118              
119 1 50       36 open( my $new_watches, '<', $file ) or die "Unable to read specified file\n";
120              
121 1         17 my @new = map { chomp; $_ } <$new_watches>;
  2         5  
  2         5  
122 1         12 my @old = $self->_watch_list;
123              
124 1         4 for my $old (@old) {
125 1 50       3 next if ( grep { $_ eq $old } @new );
  2         7  
126 0         0 $self->rm($old);
127             }
128 1         2 for my $new (@new) {
129 2 100       3 next if ( grep { $_ eq $new } @old );
  2         5  
130 1         18 $self->add($new);
131             }
132              
133 1         16 return 0;
134             }
135              
136             sub writewatch {
137 1     1 1 774 my $self = _new(shift);
138              
139 1 50       4 copy( $self->_rel2dir('.dest/watch'), $self->_rel2dir('dest.watch') ) or die "$!\n";
140              
141 1         358 return 0;
142             }
143              
144             sub make {
145 2     2 1 2467 my ( $self, $path, $ext ) = @_;
146 2 50       6 die "No name specified; usage: dest make [path]\n" unless ($path);
147              
148 2 100       6 $ext = '.' . $ext if ( defined $ext );
149 2   100     9 $ext //= '';
150              
151             try {
152             mkpath($path);
153             for ( qw( deploy verify revert ) ) {
154             open( my $file, '>', "$path/$_$ext" ) or die;
155             print $file "\n";
156             }
157             }
158 2         3 catch {
159             die "Failed to fully make $path; check permissions or existing files\n";
160             };
161              
162 2         14 $self->expand($path);
163              
164 2         9 return 0;
165             }
166              
167             sub expand {
168 2     2 1 6 my ( $self, $path ) = @_;
169              
170 2         4 print join( ' ', map { <"$path/$_*"> } qw( deploy verify revert ) ), "\n";
  6         314  
171              
172 2         9 return 0;
173             }
174              
175             sub list {
176 2     2 1 6945 my $self = _new(shift);
177 2         7 my ($filter) = @_;
178              
179 2         10 my $tree = $self->_actions_tree($filter);
180 2         9 for my $path ( sort keys %$tree ) {
181 2 50       4 print $path, ( ( @{ $tree->{$path} } ) ? ' actions:' : ' has no actions' ), "\n";
  2         71  
182 2         8 print ' ', $_, "\n" for ( @{ $tree->{$path} } );
  2         55  
183             }
184              
185 2         18 return 0;
186             }
187              
188             sub prereqs {
189 1     1 1 1534 my $self = _new(shift);
190 1         2 my ($filter) = @_;
191              
192 1         2 for my $action ( @{ $self->_prereq_tree($filter)->{actions} } ) {
  1         4  
193 3 100       6 print $action->{action}, ( ( @{ $action->{prereqs} } ) ? ' prereqs:' : ' has no prereqs' ), "\n";
  3         44  
194 3         8 print ' ', $_, "\n" for ( @{ $action->{prereqs} } );
  3         15  
195             }
196              
197 1         8 return 0;
198             }
199              
200             sub status {
201 5     5 1 11405 my $self = _new(shift);
202              
203 5 50       14 if ( -f $self->_rel2dir('dest.watch') ) {
204 5         15 my $diff = Text::Diff::diff( $self->_rel2dir('.dest/watch'), $self->_rel2dir('dest.watch') );
205 5 50       1629 warn "Diff between current watch list and dest.watch file:\n" . $diff . "\n" if ($diff);
206             }
207              
208 5         10 for my $path ( @{ $self->_status_data->{paths} } ) {
  5         17  
209 5         140 print "$path->{state} - $path->{path}\n";
210              
211 5         18 for my $action ( @{ $path->{actions} } ) {
  5         14  
212 12 100       33 unless ( $action->{modified} ) {
213 10 100       115 print ' ' . ( ( $action->{deployed} ) ? '-' : '+' ) . ' ' . $action->{action} . "\n";
214             }
215             else {
216 2         22 print " $action->{action}\n";
217 2         26 print " M $action->{file}\n";
218             }
219             }
220             }
221              
222 5         38 return 0;
223             }
224              
225             sub diff {
226 2     2 1 1292 my $self = _new(shift);
227 2         5 my ($path) = @_;
228              
229 2 100       6 if ( not defined $path ) {
230 1         3 $self->diff($_) for ( $self->_watch_list );
231 1         5 return 0;
232             }
233              
234             File::DirCompare->compare( $self->_rel2dir( '.dest/' . $self->_rel2root($path) ), $path, sub {
235 3     3   2412 my ( $a, $b ) = @_;
236 3   100     11 $a ||= '';
237 3   100     12 $b ||= '';
238              
239 3 100 33     62 return if ( $a =~ /\/dest.wrap$/ or $b =~ /\/dest.wrap$/ or not -f $a or not -f $b );
      66        
      66        
240 1         6 print Text::Diff::diff( $a, $b );
241 1         504 return;
242 1         4 } );
243              
244 1         10 return 0;
245             }
246              
247             sub clean {
248 2     2 1 1441 my $self = _new(shift);
249              
250 2 100       5 if (@_) {
251 1         3 for (@_) {
252 1         5 my $dest = $self->_rel2dir(".dest/$_");
253 1         337 rmtree($dest);
254 1         7 rcopy( $self->_rel2dir($_), $dest );
255             }
256             }
257             else {
258 1         4 for ( map { $self->_rel2root($_) } $self->_watch_list ) {
  1         4  
259 1         166 my $dest = $self->_rel2dir(".dest/$_");
260 1         964 rmtree($dest);
261 1         7 dircopy( $self->_rel2dir($_), $dest );
262             }
263             }
264              
265 2         6658 return 0;
266             }
267              
268             sub preinstall {
269 1     1 1 688 my $self = _new(shift);
270              
271 1 50       4 if (@_) {
272 0         0 for (@_) {
273 0         0 my $dest = $self->_rel2dir(".dest/$_");
274 0         0 rmtree($dest);
275 0         0 mkdir($dest);
276             }
277             }
278             else {
279 1         4 for ( map { $self->_rel2root($_) } $self->_watch_list ) {
  1         5  
280 1         166 my $dest = $self->_rel2dir(".dest/$_");
281 1         955 rmtree($dest);
282 1         40 mkdir($dest);
283             }
284             }
285              
286 1         9 return 0;
287             }
288              
289             sub deploy {
290 5     5 1 7536 my $self = _new(shift);
291 5         19 my ( $dry_run, $action ) = _dry_check(@_);
292 5 50       17 die "File to deploy required; usage: dest deploy file\n" unless ($action);
293              
294 5         9 my $redeploy = delete $self->{redeploy};
295 5         16 my $execute_stack = $self->_build_execute_stack( $action, 'deploy', undef, $redeploy );
296             die "Action already deployed\n" if (
297             not @$execute_stack or
298 5 50 66     60 not scalar( grep { $_->{action} eq $action and $_->{type} eq 'deploy' } @$execute_stack )
  8 100       44  
299             );
300              
301 4 100       14 unless ($dry_run) {
302 3         13 $self->_execute_action($_) for (@$execute_stack);
303             }
304             else {
305 1         5 _dry_run_report($execute_stack);
306             }
307              
308 4         186 return 0;
309             }
310              
311             sub redeploy {
312 1     1 1 1341 my $self = _new(shift);
313 1         11 $self->{redeploy} = 1;
314 1         9 return $self->deploy(@_);
315             }
316              
317             sub revdeploy {
318 1     1 1 3052 my $self = _new(shift);
319 1         11 my ($action) = @_;
320              
321 1         18 $self->revert($action);
322 1         23 return $self->deploy($action);
323             }
324              
325             sub verify {
326 1     1 1 1330 my $self = _new(shift);
327 1         2 my ($action) = @_;
328              
329 1         5 return $self->_execute_action( $self->_build_execute_stack( $action, 'verify' )->[0] );
330             }
331              
332             sub revert {
333 3     3 1 6606 my $self = _new(shift);
334 3         23 my ( $dry_run, $action ) = _dry_check(@_);
335 3 50       16 die "File to revert required; usage: dest revert file\n" unless ($action);
336              
337 3         20 my $execute_stack = $self->_build_execute_stack( $action, 'revert' );
338             die "Action not deployed\n" if (
339             not @$execute_stack or
340 3 100 33     34 not scalar( grep { $_->{action} eq $action and $_->{type} eq 'revert' } @$execute_stack )
  7 50       48  
341             );
342              
343 3 100       9 unless ($dry_run) {
344 2         9 $self->_execute_action($_) for (@$execute_stack);
345             }
346             else {
347 1         6 _dry_run_report($execute_stack);
348             }
349              
350 3         85 return 0;
351             }
352              
353             sub update {
354 3     3 1 6092 my $self = _new(shift);
355 3         22 my ( $dry_run, @incs ) = _dry_check(@_);
356              
357 3         11 my $seen_action = {};
358 3         10 my $execute_stack;
359              
360 3         5 for (
361             sort {
362             ( $b->{modified} || 0 ) <=> ( $a->{modified} || 0 ) ||
363             $a->{action} cmp $b->{action}
364 18 50 50     92 }
      100        
365 15         44 grep { not $_->{matches} }
366 3         15 values %{ $self->_status_data->{actions} }
367             ) {
368 2         14 push( @$execute_stack, @{ $self->_build_execute_stack( $_->{action}, 'revert' ) } ) if (
369             $_->{modified} or $_->{deployed}
370 14 100 100     60 );
371 14         24 push( @$execute_stack, @{ $self->_build_execute_stack( $_->{action}, 'deploy', $seen_action ) } );
  14         32  
372             }
373              
374             $execute_stack = [
375             grep {
376 3 100       16 my $execution = $_;
  8         8  
377 8         8 my $match = 0;
378              
379 8         10 for (@incs) {
380 8 50       19 if ( index( $execution->{file}, $_ ) > -1 ) {
381 8         5 $match = 1;
382 8         19 last;
383             }
384             }
385              
386 8         12 $match;
387             }
388             @$execute_stack
389             ] if (@incs);
390              
391 3 100       10 unless ($dry_run) {
392 2         10 $self->_execute_action($_) for (@$execute_stack);
393             }
394             else {
395 1         3 _dry_run_report($execute_stack);
396             }
397              
398 3         177 return 0;
399             }
400              
401             sub version {
402 1   50 1 1 1767 print 'dest version ', $__PACKAGE__::VERSION || 0, "\n";
403 1         6 return 0;
404             }
405              
406             sub _new {
407 50     50   127 my ( $self, $expect_no_root_dir ) = @_;
408              
409 50 100       172 if ( not ref $self ) {
410 41         101 $self = bless( {}, __PACKAGE__ );
411              
412 41         231 $self->{root_dir} = Path::Tiny->cwd;
413              
414 41         1840 while ( not $self->{root_dir}->child('.dest')->is_dir ) {
415 28 100       1422 if ( $self->{root_dir}->is_rootdir ) {
416 4         79 $self->{root_dir} = '';
417 4         11 last;
418             }
419 24         507 $self->{root_dir} = $self->{root_dir}->parent;
420 24         916 $self->{dir_depth}++;
421             }
422              
423 41 100       1823 if ( $expect_no_root_dir ) {
424 5 100       27 die "Project already initialized\n" if $self->{root_dir};
425             }
426             else {
427 36 50       184 die "Project not initialized\n" unless $self->{root_dir};
428             }
429             }
430              
431 49         118 return $self;
432             }
433              
434             sub _dry_check {
435 11     11   37 my @clean = grep { $_ ne '-d' } @_;
  12         54  
436 11 100       55 return ( @clean != @_ ) ? 1 : 0, @clean;
437             }
438              
439             sub _rel2root {
440 131     131   473 my ( $self, $dir ) = @_;
441 131   100     876 my $path = path( $dir || '.' );
442              
443             try {
444             $path = $path->realpath;
445             }
446 131         4771 catch {
447             $path = $path->absolute;
448             };
449              
450 131         23584 return $path->relative( $self->{root_dir} )->stringify;
451             }
452              
453             sub _rel2dir {
454 449     449   18053 my ( $self, $dir ) = @_;
455 449   50     8073 return ( '../' x ( $self->{dir_depth} || 0 ) ) . ( $dir || '.' );
      50        
456             }
457              
458             sub _watch_list {
459 110     110   167 my ($self) = @_;
460 110 50       454 open( my $watch, '<', $self->_rel2dir('.dest/watch') ) or die "Unable to read ~/.dest/watch file\n";
461 110         1908 return sort map { chomp; $self->_rel2dir($_) } <$watch>;
  105         294  
  105         258  
462             }
463              
464             sub _actions_tree {
465 61     61   112 my ( $self, $filter ) = @_;
466              
467 61         77 my $tree;
468 61         103 for my $path ( $self->_watch_list ) {
469 61         131 my @actions;
470              
471             find( {
472             follow => 1,
473             no_chdir => 1,
474             wanted => sub {
475 1160 100   1160   37713 return unless ( m|/deploy(?:\.[^\/]+)?| );
476 261         1026 ( my $action = $_ ) =~ s|/deploy(?:\.[^\/]+)?||;
477              
478 261 50 66     7040 push( @actions, $action ) if (
479             not defined $filter or
480             index( $action, $filter ) > -1
481             );
482             },
483 61         6335 }, $path );
484              
485 61         588 $tree->{$path} = [ sort @actions ];
486             }
487              
488 61         137 return $tree;
489             }
490              
491             sub _prereq_tree {
492 26     26   45 my ( $self, $filter ) = @_;
493 26         58 my $tree = $self->_actions_tree($filter);
494              
495 26         40 my @actions;
496 26         137 for my $path ( sort keys %$tree ) {
497 26         39 for my $action ( @{ $tree->{$path} } ) {
  26         67  
498 114         5441 my ($file) = <"$action/deploy*">;
499 114 50       3468 open( my $content, '<', $file ) or die "Unable to read $file\n";
500              
501             my $prereqs = [
502 59         149 map { $self->_rel2dir($_) }
503 59         116 grep { defined }
504 59 50       347 map { /dest\.prereq\b[\s:=-]+(.+?)\s*$/; $1 || undef }
  59         248  
505 114         1642 grep { /dest\.prereq/ } <$content>
  187         713  
506             ];
507              
508 114         383 $action = {
509             action => $action,
510             prereqs => $prereqs,
511             };
512              
513 114         1216 push( @actions, $action );
514             }
515             }
516              
517 26         218 return { tree => $tree, actions => \@actions };
518             }
519              
520             sub _status_data {
521 33     33   64 my ($self) = @_;
522              
523 33         42 my $actions;
524 33         63 my $tree = $self->_actions_tree;
525 33         150 for my $path ( keys %$tree ) {
526 33         47 for my $action ( @{ $tree->{$path} } ) {
  33         79  
527 141         383 $actions->{$action} = {
528             action => $action,
529             deployed => 1,
530             matches => 1,
531             };
532             }
533             }
534              
535 33         41 my @paths;
536 33         79 for my $path ( $self->_watch_list ) {
537 33         82 my $printed_path = 0;
538 33         39 my $data;
539              
540             try {
541             File::DirCompare->compare(
542             $self->_rel2dir( '.dest/' . $self->_rel2root($path) ),
543             $path,
544             sub {
545 157     157   62843 my ( $a, $b ) = @_;
546 157 100 66     851 return if ( $a and $a =~ /\/dest.wrap$/ or $b and $b =~ /\/dest.wrap$/ );
      100        
      66        
547 128 100       283 $data->{state} = 'diff' unless ( $printed_path++ );
548              
549 128 100 33     295 if ( not $b ) {
    100          
    50          
550             push(
551 18         23 @{ $data->{actions} },
  18         52  
552             {
553             action => $self->_rel2dir( substr( $self->_rel2root($a), 6 ) ),
554             deployed => 1,
555             },
556             );
557             }
558             elsif ( not $a ) {
559             push(
560 93         114 @{ $data->{actions} },
  93         238  
561             {
562             action => $b,
563             deployed => 0,
564             },
565             );
566             }
567             elsif ( $a and $b ) {
568 17         159 ( my $action = $b ) =~ s,/(?:deploy|verify|revert)(?:\.[^\/]+)?$,,;
569             push(
570 17         34 @{ $data->{actions} },
  17         112  
571             {
572             action => $action,
573             modified => 1,
574             file => $b,
575             },
576             );
577             }
578              
579 128         275 return;
580             },
581             )
582             }
583             catch {
584             my $e = $_ || $@;
585             $data->{state} = '?' if ( $e =~ /Not a directory/ );
586             }
587             finally {
588             $data->{state} = 'ok' unless $printed_path;
589 33         175 };
590              
591 33         256 $data->{path} = $path;
592 33         69 push( @paths, $data );
593              
594 33 100       94 if ( ref $data->{actions} eq 'ARRAY' ) {
595 31         36 $actions->{ $_->{action} } = $_ for ( @{ $data->{actions} } );
  31         195  
596             }
597             }
598              
599 33         215 return { paths => \@paths, actions => $actions };
600             }
601              
602             sub _build_execute_stack {
603 25     25   89 my ( $self, $name, $type, $seen_action, $redeploy ) = @_;
604              
605 25         69 my @actions_stack = ($name);
606 25         39 my $prereqs = { map { $_->{action} => $_->{prereqs} } @{ $self->_prereq_tree->{actions} } };
  111         246  
  25         75  
607 25         104 my $state = $self->_status_data->{actions};
608              
609 25 100       86 if ( $type eq 'revert' ) {
610 5         14 my $postreqs;
611 5         23 for my $action ( keys %$prereqs ) {
612 21         25 push( @{ $postreqs->{$_} }, $action ) for ( @{ $prereqs->{$action} } );
  21         39  
  8         40  
613             }
614 5         15 $prereqs = $postreqs;
615             }
616              
617 25         46 my ( @execute_stack, $wraps );
618 25   100     116 $seen_action //= {};
619              
620 25         54 while (@actions_stack) {
621 39         62 my $action = shift @actions_stack;
622 39 100       116 next if ( $seen_action->{$action}++ );
623 30 100       39 push( @actions_stack, @{ $prereqs->{$action} || [] } );
  30         104  
624              
625 30 100       85 my $location = ( $type ne 'revert' )
626             ? $action
627             : $self->_rel2dir( '.dest/' . $self->_rel2root($action) );
628              
629 30         1581 my $file = ( <"$location/$type*"> )[0];
630              
631 30 50       133 unless ( exists $wraps->{$action} ) {
632 30         66 $wraps->{$action} = undef;
633 30         78 my @nodes = split( '/', $self->_rel2root($file) );
634 30         4638 pop @nodes;
635 30 100 100     168 shift @nodes if ( defined $nodes[0] and $nodes[0] eq '.dest' );
636 30         69 while (@nodes) {
637 56         184 my $path = $self->_rel2dir( join( '/', @nodes ) . '/dest.wrap' );
638 56 100       650 if ( -f $path ) {
639 28         94 $wraps->{$action} = $path;
640 28         59 last;
641             }
642 28         95 pop @nodes;
643             }
644             }
645              
646             my $add = sub {
647 27 50   27   58 die "Action file does not exist for: $type $action\n" unless ($file);
648              
649 27 50       60 my $executable = ( $wraps->{$action} ) ? $wraps->{$action} : $file;
650 27 50       343 die 'Execute permission denied for: ' . $executable . "\n" unless ( -x $executable );
651              
652             unshift(
653             @execute_stack,
654             {
655             type => $type,
656             action => $action,
657             file => $file,
658 27         175 wrap => $wraps->{$action},
659             },
660             );
661              
662 27 100       132 if ( $type eq 'deploy' ) {
663 17         813 my $verify_file = ( <"$action/verify*"> )[0];
664 17 50       62 die "Action file does not exist for: verify $action\n" unless ($verify_file);
665              
666             splice(
667             @execute_stack,
668             1,
669             0,
670             {
671             type => 'verify',
672             action => $action,
673             file => $verify_file,
674 17         205 wrap => $wraps->{$action},
675             },
676             );
677             }
678 30         167 };
679              
680 30 100       81 if ( $type eq 'deploy' ) {
    100          
    50          
681 19 100 100     117 $add->() unless ( $state->{$action}{deployed} and not $redeploy );
682             }
683             elsif ( $type eq 'revert' ) {
684 10 100 100     85 $add->() if ( $state->{$action}{deployed} or $state->{$action}{modified} );
685             }
686             elsif ( $type eq 'verify' ) {
687 1         2 $add->();
688             }
689             }
690              
691 25         162 return \@execute_stack;
692             }
693              
694             sub _dry_run_report {
695 3     3   7 my ($execute_stack) = @_;
696 3 50       278 print '' . ( ( $_->{wrap} ) ? $_->{wrap} . ' ' : '' ) . $_->{file}, "\n" for (@$execute_stack);
697             }
698              
699             sub _execute_action {
700 27     27   103 my ( $self, $input ) = @_;
701 27         210 my ( $type, $wrap, $action, $file, $location ) = @$input{ qw( type wrap action file location ) };
702              
703 27         59 my ( $out, $err, $died );
704             my $run = sub {
705             try {
706             run(
707             [ ( grep { defined } $wrap ), $file, $type ],
708             \undef, \$out, \$err,
709             ) or $died = 1;
710             }
711 27     27   70 catch {
712             $err = $_ || $@;
713             };
714              
715 27 50       268872 if ($err) {
716 0         0 ( my $err_str = $err ) =~ s/\s*at\s+.*$//;
717 0         0 chomp($err_str);
718 0 0       0 if ($died) {
719 0         0 die "Failed to execute $file: $err_str\n";
720             }
721             else {
722 0         0 warn "Warnings from executed $file: $err_str\n";
723             }
724             }
725 27         189 };
726              
727 27 100       93 if ( $type eq 'verify' ) {
728 12         38 $run->();
729 12         95 chomp($out);
730 12 50       53 die "$err\n" if ($err);
731              
732 12 50       44 if ($out) {
733 12         429 print "ok - verify: $action\n";
734             }
735             else {
736 0         0 die "not ok - verify: $action\n";
737             }
738             }
739             else {
740 15         364 print "begin - $type: $action\n";
741 15         62 $run->();
742 15         481 print "ok - $type: $action\n";
743             }
744              
745 27         515 my $dest_copy = $self->_rel2dir( '.dest/' . $self->_rel2root($action) );
746 27 100       5070 rmtree($dest_copy) unless ( $type eq 'verify' );
747 27 100       301 dircopy( $action, $dest_copy ) if ( $type eq 'deploy' );
748              
749 27         25776 return 0;
750             }
751              
752             1;
753              
754             __END__