File Coverage

blib/script/narada-install
Criterion Covered Total %
statement 147 155 94.8
branch 50 54 92.5
condition 24 27 88.8
subroutine 24 25 96.0
pod n/a
total 245 261 93.8


line stmt bran cond sub pod time code
1             #!/usr/bin/env perl
2 10     10   5021 use 5.010001;
  10         32  
3 10     10   44 use warnings;
  10         17  
  10         216  
4 10     10   41 use strict;
  10         12  
  10         159  
5 10     10   4999 use utf8;
  10         121  
  10         56  
6              
7             our $VERSION = 'v2.3.8';
8              
9 10     10   401 use FindBin;
  10         18  
  10         495  
10 10     10   53 use lib "$FindBin::Bin/../lib/perl5";
  10         14  
  10         66  
11 10     10   1470 use Path::Tiny;
  10         17  
  10         354  
12 10     10   3216 use Narada;
  10         23  
  10         288  
13 10     10   3274 use Narada::Lock qw( exclusive_lock unlock_new shared_lock unlock );
  10         24  
  10         43  
14 10     10   25149 use App::migrate;
  10         42355  
  10         357  
15 10     10   6174 use Getopt::Long qw( GetOptionsFromArray );
  10         88978  
  10         37  
16              
17 10     10   1605 use constant INITIAL_VERSION => '0.0.0';
  10         22  
  10         535  
18 10     10   54 use constant FULL_BACKUP => path('.backup/full.tar');
  10         18  
  10         65  
19 10     10   1004 use constant USAGE => <<'EOUSAGE';
  10         22  
  10         14301  
20             Usage:
21             narada-install [--allow-downgrade|-D] [--allow-restore|-R] [-f ]
22             narada-install [-f ] --path|-p ...
23             narada-install --check|-c
24             narada-install --help|-h
25             EOUSAGE
26              
27             my $Last_backup; # OPTIMIZATION delay copying last backup to drop exclusive_lock faster
28              
29              
30             main(@ARGV) if !caller;
31              
32              
33 9     9   264 sub err { die "narada-install: @_\n" };
34              
35             sub main {
36             ## no critic (RequireCarping)
37 62     62   221124 my ($allow_downgrade, $allow_restore, @files) = (0, 0);
38 62         194 my ($is_path, $check, $is_help);
39 62         0 my ($prev_version, $next_version, $path);
40 62 100       604 GetOptionsFromArray(\@_,
41             'D|allow-downgrade' => \$allow_downgrade,
42             'R|allow-restore' => \$allow_restore,
43             'f=s@' => \@files,
44             'p|path' => \$is_path,
45             'c|check=s' => \$check,
46             'h|help' => \$is_help,
47             ) or die USAGE;
48 61 100       38578 if ($is_help) {
49 4         126 print USAGE;
50 4         24 return;
51             }
52 57 100       153 if (defined $check) {
53 12 100 100     115 die USAGE if @_ || $is_path || $allow_downgrade || $allow_restore || @files;
      100        
      100        
      100        
54 7         212 say "Checking $check";
55 7         61 App::migrate->new->load($check);
56 2         16102 return;
57             }
58 45 100       111 if ($is_path) {
59 7 100       39 die USAGE if @_ <= 2;
60 3         8 $path = [@_];
61 3         7 $prev_version = $path->[0];
62 3         5 $next_version = $path->[-1];
63 3         7 $allow_downgrade= 1;
64 3         4 $allow_restore = 1;
65             }
66             else {
67 38 100       141 die USAGE if @_ != 1;
68 34         67 $next_version = $_[0];
69 34         67 $prev_version = INITIAL_VERSION;
70 34 100       103 if (path(q{.})->children(qr/\A(?![.]release\z|[.]backup\z|[.]lock)/ms)) {
71 23         6152 Narada::detect('narada');
72 23         128 ($prev_version) = path('VERSION')->lines({chomp=>1});
73             }
74             }
75 37 100       7171 if ($next_version eq $prev_version) {
76 5         21 return;
77             }
78              
79 32         175 my $migrate = load($prev_version, $next_version, @files);
80 32   66     316 $path ||= get_path($migrate, $prev_version, $next_version);
81 32         158 check_path($migrate, $path, $allow_downgrade, $allow_restore);
82 31         113 migrate($migrate, $path);
83              
84 25         6874 return;
85             }
86              
87             sub load {
88 29     29   87 my ($prev_version, $next_version, @files) = @_;
89 29         366 my $migrate = App::migrate->new;
90 29 100       506 if ($next_version ne INITIAL_VERSION) {
91 14         61 push @files, ".release/$next_version.migrate";
92             }
93 29 100       406 if (-f ".release/$prev_version.migrate") {
94 20         79 push @files, ".release/$prev_version.migrate";
95             }
96 29         77 for (@files) {
97 51         263140 say "Loading $_";
98 51         309 $migrate->load($_);
99             }
100 29         199311 return $migrate;
101             }
102              
103             sub get_path {
104 33     33   2354 my ($migrate, $prev_version, $next_version) = @_;
105 33         167 my @paths = $migrate->find_paths($prev_version, $next_version);
106 33 100       2533 if (0 == @paths) {
    100          
107 1         14 err "Unable to find migration path from $prev_version to $next_version";
108             }
109             elsif (1 != @paths) {
110             err join "\n",
111             'Found more than one upgrade path, run one of these commands to choose a path:',
112 1         2 map {"\tnarada-install --path @{$_}"} @paths;
  2         5  
  2         10  
113             }
114 31         134 return $paths[0];
115             }
116              
117             sub check_path {
118 39     39   821 my ($migrate, $path, $allow_downgrade, $allow_restore) = @_;
119 39 100       121 if ($allow_restore) {
120 15         29 $allow_downgrade = 1;
121             }
122 39         403 for my $step ($migrate->get_steps($path)) {
123 759         2625 my $t = $step->{type};
124 759   100     1501 my $is_down = $t eq 'downgrade' || $t eq 'after_downgrade';
125 759 100 100     1555 err 'Downgrade required, use --allow-downgrade to continue'
126             if $is_down && !$allow_downgrade;
127 757 100 100     1220 err 'Restore from backup required, use --allow-restore to continue'
128             if $t eq 'RESTORE' && !$allow_restore;
129 754 100       1277 if ($t eq 'RESTORE') {
130 7         82 my $f = path(".backup/full-$step->{next_version}.tar");
131 7 100       335 err "Required backup not found: $f" if !$f->is_file;
132             }
133             }
134 31         125 return;
135             }
136              
137             sub migrate {
138 28     28   75 my ($migrate, $path) = @_;
139              
140 28         440 say 'Acquire exclusive lock ...';
141 28         266 exclusive_lock();
142             {
143 28         168 local $ENV{NARADA_SKIP_LOCK} = 1;
  28         1353  
144 28         254 $Last_backup = undef; # tests may call main() many times
145 28         734 $migrate->on(BACKUP => \&_backup)
146             ->on(RESTORE => \&_restore)
147             ->on(VERSION => \&_version)
148             ->on(error => \&_error)
149             ->run($path);
150             }
151 22         1487 unlock_new();
152              
153 22         213 shared_lock();
154 22 50 33     494 if ($Last_backup && !FULL_BACKUP->exists) {
155 22         592 path($Last_backup)->copy(FULL_BACKUP);
156             }
157 22         16644 unlock();
158              
159 22         102 return;
160             }
161              
162             sub ask {
163 0     0     my ($msg, $match) = @_;
164 0           print $msg;
165             # TODO try IO::Prompter
166             ## no critic (ProhibitExplicitStdin)
167 0           while () {
168 0           chomp;
169 0 0         return $_ if /$match/ms;
170 0           print $msg;
171             }
172 0           die "Interrupted by EOF\n";
173             }
174              
175             sub _backup {
176 76     76   10535 my ($step) = @_;
177 76 100       490 if ($step->{version} ne INITIAL_VERSION) {
178 66 100       264 if ($Last_backup) {
179 37         341 path($Last_backup)->copy(FULL_BACKUP);
180             }
181 66         29078 my $file = ".backup/full-$step->{version}.tar";
182 66         1304 say "Backuping to $file";
183 66 100       52453336 system('narada-backup') == 0 or die "BACKUP failed\n";
184 62         1154 $Last_backup = $file;
185 62         2725 FULL_BACKUP->move($Last_backup);
186             }
187 72         29427 return;
188             }
189              
190             sub _restore {
191 9     9   1316 my ($step) = @_;
192 9         109 my $file = ".backup/full-$step->{version}.tar";
193 9         238 say "Restoring from $file";
194 9 100       2094758 system('narada-restore', $file) == 0 or die "RESTORE failed\n";
195 6         349 return;
196             }
197              
198             sub _version {
199 72     72   5036195 my ($step) = @_;
200 72         2320 say "Migration to $step->{version} completed";
201 72 100       821 if ($step->{version} eq INITIAL_VERSION) {
202 13         336 path('VERSION')->remove;
203             }
204             else {
205 59         1318 path('VERSION')->spew_utf8("$step->{version}\n");
206             }
207 72         375408 return;
208             }
209              
210             sub _error {
211 10     10   19174 say q{};
212 10         163 say 'YOU NEED TO MANUALLY FIX THIS ISSUE RIGHT NOW';
213 10         553 my $prompt
214             = "Please choose what to do:\n"
215             . " shell - run $ENV{SHELL} (exit from it to return to this menu)\n"
216             . " continue - continue migration (use if you have fixed this issue)\n"
217             . " restore - interrupt migration and RESTORE previous version from backup\n"
218             . 'Enter action [shell]: '
219             ;
220 10         81 while (1) {
221 10         395 my $ans = lc ask($prompt, qr/\A(?:shell|continue|restore|\s*)\z/msi);
222 10 100       452 if ($ans eq 'restore') {
    50          
223 6         253 die "Migration failed\n";
224             }
225             elsif ($ans eq 'continue') {
226 4         76 last;
227             }
228             else {
229 0         0 system $ENV{SHELL};
230             }
231             }
232 4         57 return;
233             }
234              
235              
236             1; # Magic true value required at end of module
237             __END__