File Coverage

File:lib/App/Dest.pm
Coverage:80.9%

linestmtbrancondsubpodtimecode
1package App::Dest;
2# ABSTRACT: Deployment State Manager
3
4
5
5
5
3942
23
143
use strict;
5
5
5
5
31
16
154
use warnings;
6
5
5
703
43
use 5.016;
7
8
5
5
5
35
17
409
use File::Basename qw( dirname basename );
9
5
5
5
2864
135000
1042
use File::Copy::Recursive 'dircopy';
10
5
5
5
2757
66433
253
use File::DirCompare ();
11
5
5
5
76
41
394
use File::Find 'find';
12
5
5
5
92
38
320
use File::Path qw( mkpath rmtree );
13
5
5
5
12869
895574
474
use IPC::Run 'run';
14
5
5
5
8165
27
169
use Text::Diff ();
15
5
5
5
2113
40266
79647
use Try::Tiny qw( try catch );
16
17# VERSION
18
19my %seen_files;
20
21sub init {
22
7
1
42
    my ($self) = @_;
23
24
7
191
    die "Project already initialized\n" if ( -d '.dest' );
25
6
499
    mkdir('.dest') or die "Unable to create .dest directory\n";
26
6
297
    open( my $watch, '>', '.dest/watch' ) or die "Unable to create .dest/watch file\n";
27
28
6
70
    if ( -f 'dest.watch' ) {
29
1
19
        open( my $watches, '<', 'dest.watch' ) or die "Unable to read dest.watch file\n";
30
31
1
3
3
19
11
18
        my @watches = map { chomp; $_ } <$watches>;
32
33
1
52
        my @errors;
34
1
7
        for my $watch (@watches) {
35            try {
36
3
253
                $self->add($watch);
37            }
38            catch {
39
0
0
                push( @errors, $watch . ': ' . $_ );
40
3
65
            };
41        }
42
43        warn
44            "Created new watch list based on dest.watch file:\n" .
45
3
29
            join( "\n", map { '  ' . $_ } @watches ) . "\n" .
46            (
47                (@errors)
48
1
0
15
0
                    ? "With the following errors:\n" . join( "\n", map { '  ' . $_ } @errors )
49                    : ''
50            );
51    }
52
6
83
    return 0;
53}
54
55sub add {
56
14
1
69
    my ( $self, $dir ) = @_;
57
14
75
    $dir //= '';
58
14
78
    $dir =~ s|/$||;
59
60
14
104
    die "Not in project root directory or project not initialized\n" unless ( -d '.dest' );
61
14
66
    die "No directory specified; usage: dest add [directory]\n" unless ($dir);
62
13
190
    die "Directory specified does not exist\n" unless ( -d $dir );
63
12
9
95
77
    die "Directory $dir already added\n" if ( grep { $dir eq $_ } $self->_watches );
64
65
11
187
    open( my $watch, '>>', '.dest/watch' ) or die "Unable to write .dest/watch file\n";
66
11
67
    print $watch $dir, "\n";
67
68
11
1417
    mkpath(".dest/$dir");
69
11
250
    return 0;
70}
71
72sub rm {
73
4
1
16
    my ( $self, $dir ) = @_;
74
4
179
    $dir //= '';
75
4
18
    $dir =~ s|/$||;
76
77
4
40
    die "Not in project root directory or project not initialized\n" unless ( -d '.dest' );
78
4
25
    die "No directory specified; usage: dest rm [directory]\n" unless ($dir);
79
3
5
17
38
    die "Directory $dir not currently tracked\n" unless ( grep { $dir eq $_ } $self->_watches );
80
81
2
13
    my @watches = $self->_watches;
82
2
130
    open( my $watch, '>', '.dest/watch' ) or die "Unable to write .dest/watch file\n";
83
2
4
10
27
    print $watch $_, "\n" for ( grep { $_ ne $dir } @watches );
84
85
2
794
    rmtree(".dest/$dir");
86
2
510
    return 0;
87}
88
89sub make {
90
3
1
14
    my ( $self, $path, $ext ) = @_;
91
3
26
    die "No name specified; usage: dest make [path]\n" unless ($path);
92
93
2
12
    $ext = '.' . $ext if ( defined $ext );
94
2
22
    $ext //= '';
95
96
2
8
    eval {
97
2
464
        mkpath($path);
98
2
11
        for ( qw( deploy verify revert ) ) {
99
6
257
            open( my $file, '>', "$path/$_$ext" ) or die;
100
6
570
            print $file "\n";
101        }
102    };
103
2
14
    die "Failed to fully make $path; check permissions or existing files\n" if ($@);
104
105
2
19
    $self->list($path);
106
2
13
    return 0;
107}
108
109sub list {
110
5
1
25
    my ( $self, $path ) = @_;
111
112
5
28
    if ($path) {
113
3
9
13
565
        print join( ' ', map { <"$path/$_*"> } qw( deploy verify revert ) ), "\n";
114    }
115    else {
116
2
10
        for my $path ( $self->_watches ) {
117
3
17
            print $path, "\n";
118
119            find( {
120                follow   => 1,
121                no_chdir => 1,
122                wanted   => sub {
123
11
706
                    return unless ( m|/deploy(?:\.[^\/]+)?| );
124
2
15
                    ( my $action = $_ ) =~ s|/deploy(?:\.[^\/]+)?||;
125
2
34
                    print '  ', $action, "\n";
126                },
127
3
783
            }, $path );
128        }
129    }
130
131
5
33
    return 0;
132}
133
134sub status {
135
13
1
128
    my ($self) = @_;
136
137
13
177
    die "Not in project root directory or project not initialized\n" unless ( -d '.dest' );
138
139
13
173
    if ( -f 'dest.watch' ) {
140
5
44
        my $diff = Text::Diff::diff( '.dest/watch', 'dest.watch' );
141
5
2016
        warn "Diff between current watch list and dest.watch file:\n" . $diff if ($diff);
142    }
143
144
13
52
    my %seen_actions;
145
13
149
    for ( $self->_watches ) {
146
20
95
        my ( $this_path, $printed_path ) = ( $_, 0 );
147
148
20
76
        eval { File::DirCompare->compare( ".dest/$_", $_, sub {
149
32
52514
            my ( $a, $b ) = @_;
150
32
1206
            return if ( $a and $a =~ /\/dest.wrap$/ or $b and $b =~ /\/dest.wrap$/ );
151
32
203
            print 'diff - ', $this_path, "\n" unless ( $printed_path++ );
152
153
32
149
            if ( not $b ) {
154
0
0
                print '  - ', substr( $a, 7 ), "\n";
155            }
156            elsif ( not $a ) {
157
30
151
                print "  + $b\n";
158            }
159            else {
160
2
20
                ( my $action = $b ) =~ s,/(?:deploy|verify|revert)$,,;
161
2
62
                print "  $action\n" unless ( $seen_actions{$action}++ );
162
2
13
                print "    M $b\n";
163            }
164
165
32
165
            return;
166
20
2189
        } ) };
167
168
20
7743
        if ( $@ and $@ =~ /Not a directory/ ) {
169
0
0
            print '? - ', $this_path, "\n";
170        }
171        else {
172
20
162
            print 'ok - ', $this_path, "\n" unless ($printed_path);
173        }
174    }
175
176
13
97
    return 0;
177}
178
179sub diff {
180
5
1
22
    my ( $self, $path ) = @_;
181
182
5
26
    if ( not defined $path ) {
183
2
10
        $self->diff($_) for ( $self->_watches );
184
2
13
        return 0;
185    }
186
187
3
11
    eval { File::DirCompare->compare( ".dest/$path", $path, sub {
188
2
1995
        my ( $a, $b ) = @_;
189
2
12
        $a ||= '';
190
2
11
        $b ||= '';
191
192
2
23
        return if ( $a =~ /\/dest.wrap$/ or $b =~ /\/dest.wrap$/ );
193
2
14
        print Text::Diff::diff( $a, $b );
194
2
699
        return;
195
3
47
    } ) };
196
197
3
1028
    return 0;
198}
199
200sub update {
201
2
1
8
    my $self  = shift;
202
203
2
45
    die "Not in project root directory or project not initialized\n" unless ( -d '.dest' );
204
205
2
36
    if ( -f 'dest.watch' ) {
206
1
6
        my @watches = $self->_watches;
207
1
15
        open( my $watch, '<', 'dest.watch' ) or die "Unable to read dest.watch file\n";
208
209
1
3
3
31
9
11
        for my $candidate ( map { chomp; $_ } <$watch> ) {
210
3
6
10
27
            unless ( grep { $_ eq $candidate } @watches ) {
211
1
43
                $self->add($candidate);
212
1
13
                warn "Added $candidate to the watch list\n";
213            }
214        }
215    }
216
217
2
9
    my @paths   = @_;
218
2
18
    my @watches = $self->_watches;
219
220
2
11
    if (@paths) {
221        @watches = grep {
222
0
0
0
0
            my $watch = $_;
223
0
0
0
0
            grep { $_ eq $watch } @paths;
224        } @watches;
225    }
226
227    File::DirCompare->compare( ".dest/$_", $_, sub {
228
4
4393
        my ( $a, $b ) = @_;
229
4
337
        return if ( $a and $a =~ /\/dest.wrap$/ or $b and $b =~ /\/dest.wrap$/ );
230
231
4
24
        if ( not $b ) {
232
0
0
            $a =~ s|\.dest/||;
233
0
0
            $self->revert($a);
234        }
235        elsif ( not $a ) {
236
4
1016
            $self->deploy($b);
237        }
238        else {
239
240
0
0
            $a =~ s|\.dest/||;
241
0
0
            $a =~ s|/(\w+)$||;
242
0
0
            $b =~ s|/(\w+)$||;
243
244
0
0
            my $type = $1;
245
246
0
0
            if ( $type eq 'deploy' ) {
247
0
0
                $self->revert($a);
248
0
0
                $self->deploy($b);
249            }
250            else {
251
0
0
                $self->dircopy( $a, ".dest/$a" );
252            }
253        }
254
2
105
    } ) for (@watches);
255
256
2
3392
    return 0;
257}
258
259sub verify {
260
4
1
97
    my ( $self, $path ) = @_;
261
4
76
    die "Not in project root directory or project not initialized\n" unless ( -d '.dest' );
262
4
146
    return $self->_action( $path, 'verify' );
263}
264
265sub deploy {
266
11
1
129
    my ( $self, $name, $redeploy ) = @_;
267
11
142
    die "File to deploy required; usage: dest deploy file\n" unless ($name);
268
10
142
    die "Not in project root directory or project not initialized\n" unless ( -d '.dest' );
269
10
624
    my $rv = $self->_action( $name, 'deploy', $redeploy );
270
10
36
450
3717
    dircopy( $_, ".dest/$_" ) for ( grep { s|/deploy[^/]*$|| } keys %seen_files );
271
10
80393
    return $rv;
272}
273
274sub revert {
275
6
1
30
    my ( $self, $name ) = @_;
276
6
44
    die "File to revert required; usage: dest revert file\n" unless ($name);
277
5
122
    die "Not in project root directory or project not initialized\n" unless ( -d '.dest' );
278
5
128
    my $rv = $self->_action( ".dest/$name", 'revert' );
279
5
9
9
9
350
227
40624
1141
    rmtree(".dest/$_") for ( map { s|^.dest/||; $_ } grep { s|/revert[^/]*$|| } keys %seen_files );
280
5
556
    return $rv;
281}
282
283sub redeploy {
284
1
1
4
    my ( $self, $name ) = @_;
285
1
6
    return $self->deploy( $name, 'redeploy' );
286}
287
288sub revdeploy {
289
1
1
5
    my ( $self, $name ) = @_;
290
1
6
    $self->revert($name);
291
1
202
    return $self->deploy($name);
292}
293
294sub clean {
295
3
1
21
    my ($self) = @_;
296
3
43
    die "Not in project root directory or project not initialized\n" unless ( -d '.dest' );
297
3
22
    for ( $self->_watches ) {
298
3
695
        rmtree(".dest/$_");
299
3
111
        dircopy( $_, ".dest/$_" );
300    }
301
3
3739
    return 0;
302}
303
304sub preinstall {
305
1
1
5
    my ($self) = @_;
306
1
15
    die "Not in project root directory or project not initialized\n" unless ( -d '.dest' );
307
1
6
    for ( $self->_watches ) {
308
1
425
        rmtree(".dest/$_");
309
1
136
        mkdir(".dest/$_");
310    }
311
1
11
    return 0;
312}
313
314sub watches {
315
1
1
4
    my ($self) = @_;
316
1
5
    print join( "\n", $self->_watches ), "\n";
317
1
6
    return 0;
318}
319
320sub _watches {
321
46
1073
    open( my $watch, '<', '.dest/watch' ) or die "Unable to read .dest/watch file\n";
322
46
19
59
59
2238
342
247
2711
    return sort { $a cmp $b } map { chomp; $_ } <$watch>;
323}
324
325sub _action {
326
19
762
    my ( $self, $path, $type, $redeploy ) = @_;
327
19
591
    %seen_files = ();
328
329
19
173
    if ($path) {
330
17
4848
        my @files = <"$path/$type*">;
331
17
102
        my $file  = $files[0];
332
333
17
84
        unless ($file) {
334
0
0
            my $this_file = ( split( '/', $path ) )[-1];
335
0
0
            die "Unable to $type $this_file (perhaps action has already occured)\n";
336        }
337
17
357
        $self->_execute( $file, $redeploy ) or die "Failed to $type $path\n";
338    }
339    else {
340        find( {
341            follow   => 1,
342            no_chdir => 1,
343            wanted   => sub {
344
10
2379
                return unless ( /\/$type/ );
345
2
15
                $self->_execute($_) or die "Failed to $type $_\n";
346            },
347
2
137
        }, $self->_watches );
348    }
349
350
19
5444
    return 0;
351}
352
353sub _execute {
354
49
1952
    my ( $self, $file, $run_quiet, $is_dependency ) = @_;
355
49
1819
    return if ( $seen_files{$file}++ );
356
357
49
1335
    my @nodes = split( '/', $file );
358
49
432
    my $type = pop @nodes;
359
49
2439
    ( my $action = join( '/', @nodes ) ) =~ s|^\.dest/||;
360
361
49
1280
    $type =~ s/\..*$//;
362
363
49
3874
    if (
364        ( $type eq 'deploy' and not $run_quiet and -f '.dest/' . $file ) or
365        ( $type eq 'revert' and not -f $file )
366    ) {
367
0
0
        if ( $is_dependency ) {
368
0
0
            return;
369        }
370        else {
371
0
0
            die 'Action already '. $type . "ed\n";
372        }
373    }
374
375
49
7388
    open( my $content, '<', $file ) or die "Unable to read $file\n";
376
377
49
6273
    for (
378
17
81
        grep { defined }
379
17
17
443
123
        map { /dest\.prereq\b[\s:=-]+(.+?)\s*$/; $1 || undef }
380
264
2185
        grep { /dest\.prereq/ } <$content>
381    ) {
382
17
879
        my @files = <"$_/$type*">;
383
17
95
        die "Unable to find prereq \"$_/$type*\"\n" unless ( $files[0] );
384
17
989
        $self->_execute( $files[0], $run_quiet, 'dependency' ) if (
385            ( $type eq 'deploy' and not -f '.dest/' . $files[0] ) or
386            ( $type eq 'revert' and -f '.dest/' . $files[0] )
387        );
388    }
389
390
49
1863
    my $wrap;
391
49
553
    shift @nodes if ( $nodes[0] eq '.dest' );
392
49
312
    while (@nodes) {
393
98
1091
        my $path = join( '/', @nodes );
394
98
2367
        if ( -f "$path/dest.wrap" ) {
395
0
0
            $wrap = "$path/dest.wrap";
396
0
0
            last;
397        }
398
98
1389
        pop @nodes;
399    }
400
401
49
257
    if ( $type eq 'verify' ) {
402
22
82
        my ( $out, $err );
403
404        run(
405
22
44
312
605
            [ grep { defined } ( ($wrap) ? $wrap : undef ), $file ],
406            \undef, \$out, \$err,
407        ) or die "Failed to execute $file\n";
408
409
22
2720551
        chomp($out);
410
22
208
        return ($err) ? 0 : $out if ($run_quiet);
411
412
22
216
        die "$err\n" if ($err);
413
22
3938
        print '', ( ($out) ? 'ok' : 'not ok' ) . " - verify: $action\n";
414    }
415    else {
416
27
9142
        print "begin - $type: $action\n";
417
418
27
122
        eval {
419
27
54
159
844
            run( [ grep { defined } ( ($wrap) ? $wrap : undef ), $file ] );
420        };
421
27
2310880
        if ($@) {
422
0
0
            ( my $err = $@ ) =~ s/\s*at\s+.*$//;
423
0
0
            chomp($err);
424
0
0
            die "Failed to execute $file: $err\n";
425        }
426
427
27
1575
        $file =~ s|^\.dest/||;
428
27
2920
        print "ok - $type: $action\n";
429
430
27
1151
        if ( $type eq 'deploy' ) {
431
18
18
1938
1413
            ( my $verify_file = $file ) =~ s|([^/]+)$| 'verify' . substr( $1, 6 ) |e;
432
18
4711
            $self->_execute($verify_file);
433        }
434    }
435
436
49
26197
    return 1;
437}
438
4391;