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__ |