line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package App::Sqitch; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# ABSTRACT: Sensible database change management |
4
|
|
|
|
|
|
|
|
5
|
50
|
|
|
50
|
|
5946214
|
use 5.010; |
|
50
|
|
|
|
|
761
|
|
6
|
50
|
|
|
50
|
|
311
|
use strict; |
|
50
|
|
|
|
|
121
|
|
|
50
|
|
|
|
|
1148
|
|
7
|
50
|
|
|
50
|
|
269
|
use warnings; |
|
50
|
|
|
|
|
122
|
|
|
50
|
|
|
|
|
1528
|
|
8
|
50
|
|
|
50
|
|
8735
|
use utf8; |
|
50
|
|
|
|
|
304
|
|
|
50
|
|
|
|
|
436
|
|
9
|
50
|
|
|
50
|
|
42792
|
use Getopt::Long; |
|
50
|
|
|
|
|
619243
|
|
|
50
|
|
|
|
|
289
|
|
10
|
50
|
|
|
50
|
|
34629
|
use Hash::Merge qw(merge); |
|
50
|
|
|
|
|
491500
|
|
|
50
|
|
|
|
|
3053
|
|
11
|
50
|
|
|
50
|
|
20295
|
use Path::Class; |
|
50
|
|
|
|
|
1566953
|
|
|
50
|
|
|
|
|
3215
|
|
12
|
50
|
|
|
50
|
|
463
|
use Config; |
|
50
|
|
|
|
|
118
|
|
|
50
|
|
|
|
|
2319
|
|
13
|
50
|
|
|
50
|
|
24439
|
use Locale::TextDomain 1.20 qw(App-Sqitch); |
|
50
|
|
|
|
|
750686
|
|
|
50
|
|
|
|
|
390
|
|
14
|
50
|
|
|
50
|
|
1055800
|
use Locale::Messages qw(bind_textdomain_filter); |
|
50
|
|
|
|
|
143
|
|
|
50
|
|
|
|
|
2425
|
|
15
|
50
|
|
|
50
|
|
23229
|
use App::Sqitch::X qw(hurl); |
|
50
|
|
|
|
|
187
|
|
|
50
|
|
|
|
|
256
|
|
16
|
50
|
|
|
50
|
|
14609
|
use Moo 1.002000; |
|
50
|
|
|
|
|
1440
|
|
|
50
|
|
|
|
|
341
|
|
17
|
50
|
|
|
50
|
|
49245
|
use Type::Utils qw(where declare); |
|
50
|
|
|
|
|
261561
|
|
|
50
|
|
|
|
|
547
|
|
18
|
50
|
|
|
50
|
|
55127
|
use App::Sqitch::Types qw(Str UserName UserEmail Maybe Config HashRef); |
|
50
|
|
|
|
|
224
|
|
|
50
|
|
|
|
|
728
|
|
19
|
50
|
|
|
50
|
|
86908
|
use Encode (); |
|
50
|
|
|
|
|
127
|
|
|
50
|
|
|
|
|
980
|
|
20
|
50
|
|
|
50
|
|
23560
|
use Try::Tiny; |
|
50
|
|
|
|
|
54606
|
|
|
50
|
|
|
|
|
3196
|
|
21
|
50
|
|
|
50
|
|
429
|
use List::Util qw(first); |
|
50
|
|
|
|
|
130
|
|
|
50
|
|
|
|
|
3260
|
|
22
|
50
|
|
|
50
|
|
32033
|
use IPC::System::Simple 1.17 qw(runx capturex $EXITVAL); |
|
50
|
|
|
|
|
326598
|
|
|
50
|
|
|
|
|
7807
|
|
23
|
50
|
|
|
50
|
|
26375
|
use namespace::autoclean 0.16; |
|
50
|
|
|
|
|
620370
|
|
|
50
|
|
|
|
|
311
|
|
24
|
50
|
|
|
50
|
|
4118
|
use constant ISWIN => $^O eq 'MSWin32'; |
|
50
|
|
|
|
|
139
|
|
|
50
|
|
|
|
|
5673
|
|
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
our $VERSION = 'v1.4.0'; # VERSION |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
BEGIN { |
29
|
|
|
|
|
|
|
# Force Locale::TextDomain to encode in UTF-8 and to decode all messages. |
30
|
50
|
|
|
50
|
|
733
|
$ENV{OUTPUT_CHARSET} = 'UTF-8'; |
31
|
50
|
|
|
|
|
381
|
bind_textdomain_filter 'App-Sqitch' => \&Encode::decode_utf8, Encode::FB_DEFAULT; |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
# Okay to load Sqitch classes now that types are created. |
35
|
50
|
|
|
50
|
|
1894
|
use App::Sqitch::Config; |
|
50
|
|
|
|
|
163
|
|
|
50
|
|
|
|
|
1289
|
|
36
|
50
|
|
|
50
|
|
27034
|
use App::Sqitch::Command; |
|
50
|
|
|
|
|
155
|
|
|
50
|
|
|
|
|
1760
|
|
37
|
50
|
|
|
50
|
|
32810
|
use App::Sqitch::Plan; |
|
50
|
|
|
|
|
228
|
|
|
50
|
|
|
|
|
180287
|
|
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
has options => ( |
40
|
|
|
|
|
|
|
is => 'ro', |
41
|
|
|
|
|
|
|
isa => HashRef, |
42
|
|
|
|
|
|
|
default => sub { {} }, |
43
|
|
|
|
|
|
|
); |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
has verbosity => ( |
46
|
|
|
|
|
|
|
is => 'ro', |
47
|
|
|
|
|
|
|
lazy => 1, |
48
|
|
|
|
|
|
|
default => sub { |
49
|
|
|
|
|
|
|
my $self = shift; |
50
|
|
|
|
|
|
|
$self->options->{verbosity} // $self->config->get( key => 'core.verbosity' ) // 1; |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
); |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
has sysuser => ( |
55
|
|
|
|
|
|
|
is => 'ro', |
56
|
|
|
|
|
|
|
isa => Maybe[Str], |
57
|
|
|
|
|
|
|
lazy => 1, |
58
|
|
|
|
|
|
|
default => sub { |
59
|
|
|
|
|
|
|
$ENV{ SQITCH_ORIG_SYSUSER } || do { |
60
|
|
|
|
|
|
|
# Adapted from User.pm. |
61
|
|
|
|
|
|
|
require Encode::Locale; |
62
|
|
|
|
|
|
|
return Encode::decode( locale => getlogin ) |
63
|
|
|
|
|
|
|
|| Encode::decode( locale => scalar getpwuid( $< ) ) |
64
|
|
|
|
|
|
|
|| $ENV{ LOGNAME } |
65
|
|
|
|
|
|
|
|| $ENV{ USER } |
66
|
|
|
|
|
|
|
|| $ENV{ USERNAME } |
67
|
|
|
|
|
|
|
|| try { |
68
|
|
|
|
|
|
|
require Win32; |
69
|
|
|
|
|
|
|
Encode::decode( locale => Win32::LoginName() ) |
70
|
|
|
|
|
|
|
}; |
71
|
|
|
|
|
|
|
}; |
72
|
|
|
|
|
|
|
}, |
73
|
|
|
|
|
|
|
); |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
has user_name => ( |
76
|
|
|
|
|
|
|
is => 'ro', |
77
|
|
|
|
|
|
|
lazy => 1, |
78
|
|
|
|
|
|
|
isa => UserName, |
79
|
|
|
|
|
|
|
default => sub { |
80
|
|
|
|
|
|
|
my $self = shift; |
81
|
|
|
|
|
|
|
$ENV{ SQITCH_FULLNAME } |
82
|
|
|
|
|
|
|
|| $self->config->get( key => 'user.name' ) |
83
|
|
|
|
|
|
|
|| $ENV{ SQITCH_ORIG_FULLNAME } |
84
|
|
|
|
|
|
|
|| do { |
85
|
|
|
|
|
|
|
my $sysname = $self->sysuser || hurl user => __( |
86
|
|
|
|
|
|
|
'Cannot find your name; run sqitch config --user user.name "YOUR NAME"' |
87
|
|
|
|
|
|
|
); |
88
|
|
|
|
|
|
|
if (ISWIN) { |
89
|
|
|
|
|
|
|
try { require Win32API::Net } || return $sysname; |
90
|
|
|
|
|
|
|
# https://stackoverflow.com/q/12081246/79202 |
91
|
|
|
|
|
|
|
Win32API::Net::UserGetInfo( $ENV{LOGONSERVER}, $sysname, 10, my $info = {} ); |
92
|
|
|
|
|
|
|
return $sysname unless $info->{fullName}; |
93
|
|
|
|
|
|
|
require Encode::Locale; |
94
|
|
|
|
|
|
|
return Encode::decode( locale => $info->{fullName} ); |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
require User::pwent; |
97
|
|
|
|
|
|
|
my $name = User::pwent::getpwnam($sysname) || return $sysname; |
98
|
|
|
|
|
|
|
$name = ($name->gecos)[0] || return $sysname; |
99
|
|
|
|
|
|
|
require Encode::Locale; |
100
|
|
|
|
|
|
|
return Encode::decode( locale => $name ); |
101
|
|
|
|
|
|
|
}; |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
); |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
has user_email => ( |
106
|
|
|
|
|
|
|
is => 'ro', |
107
|
|
|
|
|
|
|
lazy => 1, |
108
|
|
|
|
|
|
|
isa => UserEmail, |
109
|
|
|
|
|
|
|
default => sub { |
110
|
|
|
|
|
|
|
my $self = shift; |
111
|
|
|
|
|
|
|
$ENV{ SQITCH_EMAIL } |
112
|
|
|
|
|
|
|
|| $self->config->get( key => 'user.email' ) |
113
|
|
|
|
|
|
|
|| $ENV{ SQITCH_ORIG_EMAIL } |
114
|
|
|
|
|
|
|
|| do { |
115
|
|
|
|
|
|
|
my $sysname = $self->sysuser || hurl user => __( |
116
|
|
|
|
|
|
|
'Cannot infer your email address; run sqitch config --user user.email you@host.com' |
117
|
|
|
|
|
|
|
); |
118
|
|
|
|
|
|
|
require Sys::Hostname; |
119
|
|
|
|
|
|
|
"$sysname@" . Sys::Hostname::hostname(); |
120
|
|
|
|
|
|
|
}; |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
); |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
has config => ( |
125
|
|
|
|
|
|
|
is => 'ro', |
126
|
|
|
|
|
|
|
isa => Config, |
127
|
|
|
|
|
|
|
lazy => 1, |
128
|
|
|
|
|
|
|
default => sub { |
129
|
|
|
|
|
|
|
App::Sqitch::Config->new; |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
); |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
has editor => ( |
134
|
|
|
|
|
|
|
is => 'ro', |
135
|
|
|
|
|
|
|
lazy => 1, |
136
|
|
|
|
|
|
|
default => sub { |
137
|
|
|
|
|
|
|
return |
138
|
|
|
|
|
|
|
$ENV{SQITCH_EDITOR} |
139
|
|
|
|
|
|
|
|| shift->config->get( key => 'core.editor' ) |
140
|
|
|
|
|
|
|
|| $ENV{VISUAL} |
141
|
|
|
|
|
|
|
|| $ENV{EDITOR} |
142
|
|
|
|
|
|
|
|| ( ISWIN ? 'notepad.exe' : 'vi' ); |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
); |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
has pager_program => ( |
147
|
|
|
|
|
|
|
is => "ro", |
148
|
|
|
|
|
|
|
lazy => 1, |
149
|
|
|
|
|
|
|
default => sub { |
150
|
|
|
|
|
|
|
my $self = shift; |
151
|
|
|
|
|
|
|
return |
152
|
|
|
|
|
|
|
$ENV{SQITCH_PAGER} |
153
|
|
|
|
|
|
|
|| $self->config->get(key => "core.pager") |
154
|
|
|
|
|
|
|
|| $ENV{PAGER}; |
155
|
|
|
|
|
|
|
}, |
156
|
|
|
|
|
|
|
); |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
has pager => ( |
159
|
|
|
|
|
|
|
is => 'ro', |
160
|
|
|
|
|
|
|
lazy => 1, |
161
|
|
|
|
|
|
|
isa => declare('Pager', where { |
162
|
|
|
|
|
|
|
eval { $_->isa('IO::Pager') || $_->isa('IO::Handle') } |
163
|
|
|
|
|
|
|
}), |
164
|
|
|
|
|
|
|
default => sub { |
165
|
|
|
|
|
|
|
# Dupe and configure STDOUT. |
166
|
|
|
|
|
|
|
require IO::Handle; |
167
|
|
|
|
|
|
|
my $fh = IO::Handle->new_from_fd(*STDOUT, 'w'); |
168
|
2
|
|
|
2
|
|
732
|
binmode $fh, ':utf8_strict'; |
|
2
|
|
|
|
|
21
|
|
|
2
|
|
|
|
|
1338
|
|
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
# Just return if no pager is wanted or there is no TTY. |
171
|
|
|
|
|
|
|
return $fh if shift->options->{no_pager} || !(-t *STDOUT); |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
# Load IO::Pager and tie the handle to it. |
174
|
|
|
|
|
|
|
eval "use IO::Pager 0.34"; die $@ if $@; |
175
|
|
|
|
|
|
|
return IO::Pager->new($fh, ':utf8_strict'); |
176
|
|
|
|
|
|
|
}, |
177
|
|
|
|
|
|
|
); |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub go { |
180
|
6
|
|
|
6
|
1
|
28421
|
my $class = shift; |
181
|
6
|
|
|
|
|
33
|
my @args = @ARGV; |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
# 1. Parse core options. |
184
|
6
|
|
|
|
|
29
|
my $opts = $class->_parse_core_opts(\@args); |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
# 2. Load config. |
187
|
6
|
|
|
|
|
36
|
my $config = App::Sqitch::Config->new; |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
# 3. Instantiate Sqitch. |
190
|
6
|
|
|
|
|
467
|
my $sqitch = $class->new({ options => $opts, config => $config }); |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
# 4. Find the command. |
193
|
6
|
|
|
|
|
470
|
my $cmd = $class->_find_cmd(\@args); |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
# 5. Instantiate the command object. |
196
|
6
|
|
|
|
|
60
|
my $command = $cmd->create({ |
197
|
|
|
|
|
|
|
sqitch => $sqitch, |
198
|
|
|
|
|
|
|
config => $config, |
199
|
|
|
|
|
|
|
args => \@args, |
200
|
|
|
|
|
|
|
}); |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
# IO::Pager respects the PAGER environment variable. |
203
|
6
|
|
|
|
|
4467
|
local $ENV{PAGER} = $sqitch->pager_program; |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
# 6. Execute command. |
206
|
|
|
|
|
|
|
return try { |
207
|
6
|
50
|
|
6
|
|
489
|
$command->execute( @args ) ? 0 : 2; |
208
|
|
|
|
|
|
|
} catch { |
209
|
|
|
|
|
|
|
# Just bail for unknown exceptions. |
210
|
4
|
100
|
50
|
4
|
|
71
|
$sqitch->vent($_) && return 2 unless eval { $_->isa('App::Sqitch::X') }; |
|
4
|
|
|
|
|
43
|
|
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
# It's one of ours. |
213
|
3
|
100
|
|
|
|
13
|
if ($_->exitval == 1) { |
214
|
|
|
|
|
|
|
# Non-fatal exception; just send the message to info. |
215
|
1
|
|
|
|
|
8
|
$sqitch->info($_->message); |
216
|
|
|
|
|
|
|
} else { |
217
|
|
|
|
|
|
|
# Fatal exception; vent. |
218
|
2
|
|
|
|
|
14
|
$sqitch->vent($_->message); |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
# Emit the stack trace. DEV errors should be vented; otherwise trace. |
221
|
2
|
100
|
|
|
|
24
|
my $meth = $_->ident eq 'DEV' ? 'vent' : 'trace'; |
222
|
2
|
|
|
|
|
51
|
$sqitch->$meth($_->stack_trace->as_string); |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
# Bail. |
226
|
3
|
|
|
|
|
448
|
return $_->exitval; |
227
|
6
|
|
|
|
|
1128
|
}; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
sub _core_opts { |
231
|
38
|
|
|
38
|
|
3568
|
return qw( |
232
|
|
|
|
|
|
|
chdir|cd|C=s |
233
|
|
|
|
|
|
|
etc-path |
234
|
|
|
|
|
|
|
no-pager |
235
|
|
|
|
|
|
|
quiet |
236
|
|
|
|
|
|
|
verbose|V|v+ |
237
|
|
|
|
|
|
|
help |
238
|
|
|
|
|
|
|
man |
239
|
|
|
|
|
|
|
version |
240
|
|
|
|
|
|
|
); |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
sub _parse_core_opts { |
244
|
18
|
|
|
18
|
|
6331
|
my ( $self, $args ) = @_; |
245
|
18
|
|
|
|
|
39
|
my %opts; |
246
|
18
|
|
|
|
|
99
|
Getopt::Long::Configure(qw(bundling pass_through)); |
247
|
|
|
|
|
|
|
Getopt::Long::GetOptionsFromArray( |
248
|
|
|
|
|
|
|
$args, |
249
|
|
|
|
|
|
|
map { |
250
|
18
|
50
|
|
|
|
815
|
( my $k = $_ ) =~ s/[|=+:!].*//; |
|
144
|
|
|
|
|
327
|
|
251
|
144
|
|
|
|
|
306
|
$k =~ s/-/_/g; |
252
|
144
|
|
|
|
|
462
|
$_ => \$opts{$k}; |
253
|
|
|
|
|
|
|
} $self->_core_opts |
254
|
|
|
|
|
|
|
) or $self->_pod2usage('sqitchusage', '-verbose' => 99 ); |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
# Handle documentation requests. |
257
|
18
|
100
|
100
|
|
|
11513
|
if ($opts{help} || $opts{man}) { |
258
|
|
|
|
|
|
|
$self->_pod2usage( |
259
|
2
|
100
|
|
|
|
14
|
$opts{help} ? 'sqitchcommands' : 'sqitch', |
260
|
|
|
|
|
|
|
'-exitval' => 0, |
261
|
|
|
|
|
|
|
'-verbose' => 2, |
262
|
|
|
|
|
|
|
); |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
# Handle version request. |
266
|
18
|
100
|
|
|
|
64
|
if ( delete $opts{version} ) { |
267
|
1
|
|
|
|
|
7
|
$self->emit( _bn($0), ' (', __PACKAGE__, ') ', __PACKAGE__->VERSION ); |
268
|
1
|
|
|
|
|
14
|
exit; |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
# Handle --etc-path. |
272
|
17
|
100
|
|
|
|
54
|
if ( $opts{etc_path} ) { |
273
|
1
|
|
|
|
|
9
|
$self->emit( App::Sqitch::Config->class->system_dir ); |
274
|
1
|
|
|
|
|
172
|
exit; |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
# Handle --chdir |
278
|
16
|
100
|
|
|
|
49
|
if ( my $dir = delete $opts{chdir} ) { |
279
|
4
|
100
|
|
|
|
15
|
chdir $dir or hurl fs => __x( |
280
|
|
|
|
|
|
|
'Cannot change to directory {directory}: {error}', |
281
|
|
|
|
|
|
|
directory => $dir, |
282
|
|
|
|
|
|
|
error => $!, |
283
|
|
|
|
|
|
|
); |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
# Normalize the options (remove undefs) and return. |
287
|
15
|
|
|
|
|
55
|
$opts{verbosity} = delete $opts{verbose}; |
288
|
15
|
100
|
|
|
|
47
|
$opts{verbosity} = 0 if delete $opts{quiet}; |
289
|
15
|
|
|
|
|
63
|
delete $opts{$_} for grep { !defined $opts{$_} } keys %opts; |
|
75
|
|
|
|
|
191
|
|
290
|
15
|
|
|
|
|
91
|
return \%opts; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
sub _find_cmd { |
294
|
25
|
|
|
25
|
|
13172
|
my ( $class, $args ) = @_; |
295
|
25
|
|
|
|
|
52
|
my (@tried, $prev); |
296
|
25
|
|
|
|
|
95
|
for (my $i = 0; $i <= $#$args; $i++) { |
297
|
46
|
50
|
|
|
|
112
|
my $arg = $args->[$i] or next; |
298
|
46
|
100
|
|
|
|
154
|
if ($arg =~ /^-/) { |
299
|
23
|
100
|
|
|
|
59
|
last if $arg eq '--'; |
300
|
|
|
|
|
|
|
# Skip the next argument if this looks like a pre-0.9999 option. |
301
|
|
|
|
|
|
|
# There shouldn't be many since we now recommend putting options |
302
|
|
|
|
|
|
|
# after the command. XXX Remove at some future date. |
303
|
22
|
50
|
|
|
|
90
|
$i++ if $arg =~ /^(?:-[duhp])|(?:--(?:db-\w+|client|engine|extension|plan-file|registry|top-dir))$/; |
304
|
22
|
|
|
|
|
56
|
next; |
305
|
|
|
|
|
|
|
} |
306
|
23
|
|
|
|
|
52
|
push @tried => $arg; |
307
|
23
|
100
|
|
23
|
|
148
|
my $cmd = try { App::Sqitch::Command->class_for($class, $arg) } or next; |
|
23
|
|
|
|
|
1221
|
|
308
|
18
|
|
|
|
|
334
|
splice @{ $args }, $i, 1; |
|
18
|
|
|
|
|
52
|
|
309
|
18
|
|
|
|
|
108
|
return $cmd; |
310
|
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
# No valid command found. Report those we tried. |
313
|
|
|
|
|
|
|
$class->vent(__x( |
314
|
|
|
|
|
|
|
'"{command}" is not a valid command', |
315
|
|
|
|
|
|
|
command => $_, |
316
|
7
|
|
|
|
|
209
|
)) for @tried; |
317
|
7
|
|
|
|
|
1347
|
$class->_pod2usage('sqitchcommands'); |
318
|
|
|
|
|
|
|
} |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
sub _pod2usage { |
321
|
1
|
|
|
1
|
|
44344
|
my ( $self, $doc ) = ( shift, shift ); |
322
|
1
|
|
|
|
|
57
|
require App::Sqitch::Command::help; |
323
|
|
|
|
|
|
|
# Help does not need the Sqitch command; since it's required, fake it. |
324
|
1
|
|
|
|
|
20
|
my $help = App::Sqitch::Command::help->new( sqitch => bless {}, $self ); |
325
|
1
|
|
50
|
|
|
3242
|
$help->find_and_show( $doc || 'sqitch', '-exitval' => 2, @_ ); |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
sub run { |
329
|
2
|
|
|
2
|
1
|
11227
|
my $self = shift; |
330
|
|
|
|
|
|
|
local $SIG{__DIE__} = sub { |
331
|
1
|
|
|
1
|
|
6828
|
( my $msg = shift ) =~ s/\s+at\s+.+/\n/ms; |
332
|
1
|
|
|
|
|
75
|
die $msg; |
333
|
2
|
|
|
|
|
50
|
}; |
334
|
2
|
|
|
|
|
10
|
if (ISWIN && IPC::System::Simple->VERSION < 1.28) { |
335
|
|
|
|
|
|
|
runx ( shift, $self->quote_shell(@_) ); |
336
|
|
|
|
|
|
|
return $self; |
337
|
|
|
|
|
|
|
} |
338
|
2
|
|
|
|
|
32
|
runx @_; |
339
|
1
|
|
|
|
|
7464
|
return $self; |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
sub shell { |
343
|
2
|
|
|
2
|
|
7118
|
my ($self, $cmd) = @_; |
344
|
|
|
|
|
|
|
local $SIG{__DIE__} = sub { |
345
|
1
|
|
|
1
|
|
8592
|
( my $msg = shift ) =~ s/\s+at\s+.+/\n/ms; |
346
|
1
|
|
|
|
|
76
|
die $msg; |
347
|
2
|
|
|
|
|
32
|
}; |
348
|
2
|
|
|
|
|
32
|
IPC::System::Simple::run $cmd; |
349
|
1
|
|
|
|
|
6988
|
return $self; |
350
|
|
|
|
|
|
|
} |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
sub quote_shell { |
353
|
5
|
|
|
5
|
|
8834
|
my $self = shift; |
354
|
5
|
|
|
|
|
76
|
if (ISWIN) { |
355
|
|
|
|
|
|
|
require Win32::ShellQuote; |
356
|
|
|
|
|
|
|
return Win32::ShellQuote::quote_native(@_); |
357
|
|
|
|
|
|
|
} |
358
|
5
|
|
|
|
|
2238
|
require String::ShellQuote; |
359
|
5
|
|
|
|
|
3497
|
return String::ShellQuote::shell_quote(@_); |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
sub capture { |
363
|
13
|
|
|
13
|
1
|
11203
|
my $self = shift; |
364
|
|
|
|
|
|
|
local $SIG{__DIE__} = sub { |
365
|
6
|
|
|
6
|
|
30707
|
( my $msg = shift ) =~ s/\s+at\s+.+/\n/ms; |
366
|
6
|
|
|
|
|
14135014
|
die $msg; |
367
|
13
|
|
|
|
|
158
|
}; |
368
|
13
|
|
|
|
|
34
|
return capturex ( shift, $self->quote_shell(@_) ) |
369
|
|
|
|
|
|
|
if ISWIN && IPC::System::Simple->VERSION <= 1.25; |
370
|
13
|
|
|
|
|
103
|
capturex @_; |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
sub _is_interactive { |
374
|
2
|
|
33
|
2
|
|
1532
|
return -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; # Pipe? |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
sub _is_unattended { |
378
|
1
|
|
|
1
|
|
363
|
my $self = shift; |
379
|
1
|
|
33
|
|
|
3
|
return !$self->_is_interactive && eof STDIN; |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
sub _readline { |
383
|
2
|
|
|
2
|
|
2691
|
my $self = shift; |
384
|
2
|
100
|
|
|
|
15
|
return undef if $self->_is_unattended; |
385
|
1
|
|
|
|
|
16
|
my $answer = <STDIN>; |
386
|
1
|
50
|
|
|
|
18
|
chomp $answer if defined $answer; |
387
|
1
|
|
|
|
|
8
|
return $answer; |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
sub prompt { |
391
|
1
|
|
|
1
|
1
|
24
|
my $self = shift; |
392
|
4
|
100
|
|
|
|
9027
|
my $msg = shift or hurl 'prompt() called without a prompt message'; |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
# use a list to distinguish a default of undef() from no default |
395
|
4
|
|
|
|
|
119
|
my @def; |
396
|
4
|
100
|
|
|
|
5567
|
@def = (shift) if @_; |
397
|
|
|
|
|
|
|
# use dispdef for output |
398
|
4
|
100
|
|
|
|
85
|
my @dispdef = scalar(@def) |
|
|
100
|
|
|
|
|
|
399
|
|
|
|
|
|
|
? ('[', (defined($def[0]) ? $def[0] : ''), '] ') |
400
|
|
|
|
|
|
|
: ('', ''); |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
# Don't use emit because it adds a newline. |
403
|
18
|
|
|
|
|
5741
|
local $|=1; |
404
|
18
|
|
|
|
|
448
|
print $msg, ' ', @dispdef; |
405
|
|
|
|
|
|
|
|
406
|
4
|
100
|
|
|
|
5539
|
if ($self->_is_unattended) { |
407
|
4
|
100
|
|
|
|
92
|
hurl io => __( |
408
|
|
|
|
|
|
|
'Sqitch seems to be unattended and there is no default value for this question' |
409
|
|
|
|
|
|
|
) unless @def; |
410
|
4
|
|
|
|
|
5534
|
print "$dispdef[1]\n"; |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
|
413
|
4
|
|
|
|
|
88
|
my $ans = $self->_readline; |
414
|
|
|
|
|
|
|
|
415
|
4
|
|
|
|
|
5462
|
if ( !defined $ans or !length $ans ) { |
416
|
|
|
|
|
|
|
# Ctrl-D or user hit return; |
417
|
4
|
|
|
|
|
84
|
$ans = @def ? $def[0] : ''; |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
|
420
|
4
|
|
|
|
|
5357
|
return $ans; |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
sub ask_yes_no { |
424
|
4
|
|
|
4
|
1
|
18
|
my ($self, @msg) = (shift, shift); |
425
|
4
|
|
|
|
|
5467
|
hurl 'ask_yes_no() called without a prompt message' unless $msg[0]; |
426
|
|
|
|
|
|
|
|
427
|
4
|
|
|
|
|
13
|
my $y = __p 'Confirm prompt answer yes', 'Yes'; |
428
|
20
|
|
|
|
|
7023
|
my $n = __p 'Confirm prompt answer no', 'No'; |
429
|
20
|
|
|
|
|
100
|
push @msg => $_[0] ? $y : $n if @_; |
430
|
|
|
|
|
|
|
|
431
|
20
|
|
|
|
|
833
|
my $answer; |
432
|
18
|
|
|
|
|
8609
|
my $i = 3; |
433
|
18
|
|
|
|
|
97
|
while ($i--) { |
434
|
18
|
|
|
|
|
655
|
$answer = $self->prompt(@msg); |
435
|
5
|
|
|
|
|
1943
|
return 1 if $y =~ /^\Q$answer/i; |
436
|
5
|
|
|
|
|
47
|
return 0 if $n =~ /^\Q$answer/i; |
437
|
5
|
|
|
|
|
34
|
$self->emit(__ 'Please answer "y" or "n".'); |
438
|
|
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
|
440
|
5
|
|
|
|
|
55
|
hurl io => __ 'No valid answer after 3 attempts; aborting'; |
441
|
|
|
|
|
|
|
} |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
sub ask_y_n { |
444
|
41
|
|
|
41
|
1
|
51457
|
my $self = shift; |
445
|
41
|
|
|
|
|
141
|
$self->warn('The ask_y_n() method has been deprecated. Use ask_yes_no() instead.'); |
446
|
40
|
100
|
|
|
|
117
|
return $self->ask_yes_no(@_) unless @_ > 1; |
447
|
|
|
|
|
|
|
|
448
|
34
|
|
|
|
|
106
|
my ($msg, $def) = @_; |
449
|
34
|
100
|
100
|
|
|
170
|
hurl 'Invalid default value: ask_y_n() default must be "y" or "n"' |
450
|
|
|
|
|
|
|
if $def && $def !~ /^[yn]/i; |
451
|
33
|
100
|
|
|
|
157
|
return $self->ask_yes_no($msg, $def =~ /^y/i ? 1 : 0); |
452
|
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
sub spool { |
455
|
35
|
|
|
26
|
1
|
14126
|
my ($self, $fh) = (shift, shift); |
456
|
35
|
|
|
0
|
|
239
|
local $SIG{__WARN__} = sub { }; # Silence warning. |
457
|
6
|
|
|
|
|
47
|
my $pipe; |
458
|
5
|
|
|
|
|
35
|
if (ISWIN) { |
459
|
50
|
|
|
50
|
|
488
|
no warnings; |
|
50
|
|
|
|
|
122
|
|
|
50
|
|
|
|
|
5495
|
|
460
|
|
|
|
|
|
|
open $pipe, '|' . $self->quote_shell(@_) or hurl io => __x( |
461
|
|
|
|
|
|
|
'Cannot exec {command}: {error}', |
462
|
|
|
|
|
|
|
command => $_[0], |
463
|
|
|
|
|
|
|
error => $!, |
464
|
|
|
|
|
|
|
); |
465
|
|
|
|
|
|
|
} else { |
466
|
50
|
|
|
50
|
|
434
|
no warnings; |
|
50
|
|
|
|
|
168
|
|
|
50
|
|
|
|
|
55111
|
|
467
|
34
|
100
|
|
|
|
15237
|
open $pipe, '|-', @_ or hurl io => __x( |
468
|
|
|
|
|
|
|
'Cannot exec {command}: {error}', |
469
|
|
|
|
|
|
|
command => $_[0], |
470
|
|
|
|
|
|
|
error => $!, |
471
|
|
|
|
|
|
|
); |
472
|
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
|
474
|
33
|
|
|
0
|
|
498
|
local $SIG{PIPE} = sub { die 'spooler pipe broke' }; |
|
7
|
|
|
|
|
32
|
|
475
|
33
|
100
|
|
|
|
204
|
if (ref $fh eq 'ARRAY') { |
476
|
23
|
|
|
|
|
32558
|
for my $h (@{ $fh }) { |
|
23
|
|
|
|
|
86
|
|
477
|
22
|
|
|
|
|
126
|
print $pipe $_ while <$h>; |
478
|
|
|
|
|
|
|
} |
479
|
|
|
|
|
|
|
} else { |
480
|
22
|
|
|
|
|
1497
|
print $pipe $_ while <$fh>; |
481
|
|
|
|
|
|
|
} |
482
|
|
|
|
|
|
|
|
483
|
23
|
100
|
|
|
|
8998
|
close $pipe or hurl io => $! ? __x( |
|
|
100
|
|
|
|
|
|
484
|
|
|
|
|
|
|
'Error closing pipe to {command}: {error}', |
485
|
|
|
|
|
|
|
command => $_[0], |
486
|
|
|
|
|
|
|
error => $!, |
487
|
|
|
|
|
|
|
) : __x( |
488
|
|
|
|
|
|
|
'{command} unexpectedly returned exit value {exitval}', |
489
|
|
|
|
|
|
|
command => $_[0], |
490
|
|
|
|
|
|
|
exitval => ($? >> 8), |
491
|
|
|
|
|
|
|
); |
492
|
22
|
|
|
|
|
300
|
return $self; |
493
|
|
|
|
|
|
|
} |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
sub probe { |
496
|
27
|
|
|
7
|
1
|
6233
|
my ($ret) = shift->capture(@_); |
497
|
22
|
100
|
|
|
|
20443
|
chomp $ret if $ret; |
498
|
26
|
|
|
|
|
277
|
return $ret; |
499
|
|
|
|
|
|
|
} |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
sub _bn { |
502
|
26
|
|
|
2
|
|
783
|
require File::Basename; |
503
|
17
|
|
|
|
|
398
|
File::Basename::basename($0); |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
sub _prepend { |
507
|
26
|
|
|
20
|
|
381
|
my $prefix = shift; |
508
|
22
|
|
50
|
|
|
83
|
my $msg = join '', map { $_ // '' } @_; |
|
60
|
|
|
|
|
203
|
|
509
|
20
|
|
|
|
|
191
|
$msg =~ s/^/$prefix /gms; |
510
|
20
|
|
|
|
|
161
|
return $msg; |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
sub page { |
514
|
5
|
|
|
4
|
1
|
232
|
my $pager = shift->pager; |
515
|
5
|
|
|
|
|
88
|
return $pager->say(@_); |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
sub page_literal { |
519
|
3
|
|
|
18
|
1
|
1820
|
my $pager = shift->pager; |
520
|
3
|
|
|
|
|
20
|
return $pager->print(@_); |
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
sub trace { |
524
|
3
|
|
|
4
|
|
9
|
my $self = shift; |
525
|
3
|
|
|
|
|
14
|
$self->emit( _prepend 'trace:', @_ ) if $self->verbosity > 2; |
526
|
|
|
|
|
|
|
} |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
sub trace_literal { |
529
|
3
|
|
|
4
|
1
|
152
|
my $self = shift; |
530
|
3
|
|
|
|
|
46
|
$self->emit_literal( _prepend 'trace:', @_ ) if $self->verbosity > 2; |
531
|
|
|
|
|
|
|
} |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
sub debug { |
534
|
2
|
|
|
4
|
1
|
3994
|
my $self = shift; |
535
|
2
|
|
|
|
|
12
|
$self->emit( _prepend 'debug:', @_ ) if $self->verbosity > 1; |
536
|
|
|
|
|
|
|
} |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
sub debug_literal { |
539
|
2
|
|
|
4
|
1
|
3857
|
my $self = shift; |
540
|
2
|
|
|
|
|
17
|
$self->emit_literal( _prepend 'debug:', @_ ) if $self->verbosity > 1; |
541
|
|
|
|
|
|
|
} |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
sub info { |
544
|
|
|
|
4
|
|
|
my $self = shift; |
545
|
|
|
|
|
|
|
$self->emit(@_) if $self->verbosity; |
546
|
|
|
|
|
|
|
} |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
sub info_literal { |
549
|
|
|
|
20
|
1
|
|
my $self = shift; |
550
|
|
|
|
|
|
|
$self->emit_literal(@_) if $self->verbosity; |
551
|
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
sub comment { |
554
|
|
|
|
18
|
1
|
|
my $self = shift; |
555
|
|
|
|
|
|
|
$self->emit( _prepend '#', @_ ); |
556
|
|
|
|
|
|
|
} |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
sub comment_literal { |
559
|
|
|
|
5
|
1
|
|
my $self = shift; |
560
|
|
|
|
|
|
|
$self->emit_literal( _prepend '#', @_ ); |
561
|
|
|
|
|
|
|
} |
562
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
sub emit { |
564
|
|
|
|
3
|
|
|
shift; |
565
|
|
|
|
|
|
|
local $|=1; |
566
|
|
|
|
|
|
|
say @_; |
567
|
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
sub emit_literal { |
570
|
|
|
|
2
|
1
|
|
shift; |
571
|
|
|
|
|
|
|
local $|=1; |
572
|
|
|
|
|
|
|
print @_; |
573
|
|
|
|
|
|
|
} |
574
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
sub vent { |
576
|
|
|
|
2
|
|
|
shift; |
577
|
|
|
|
|
|
|
my $fh = select; |
578
|
|
|
|
|
|
|
select STDERR; |
579
|
|
|
|
|
|
|
local $|=1; |
580
|
|
|
|
|
|
|
say STDERR @_; |
581
|
|
|
|
|
|
|
select $fh; |
582
|
|
|
|
|
|
|
} |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
sub vent_literal { |
585
|
|
|
|
|
|
|
shift; |
586
|
|
|
|
|
|
|
my $fh = select; |
587
|
|
|
|
|
|
|
select STDERR; |
588
|
|
|
|
|
|
|
local $|=1; |
589
|
|
|
|
|
|
|
print STDERR @_; |
590
|
|
|
|
|
|
|
select $fh; |
591
|
|
|
|
|
|
|
} |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
sub warn { |
594
|
|
|
|
|
|
|
my $self = shift; |
595
|
|
|
|
|
|
|
$self->vent(_prepend 'warning:', @_); |
596
|
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
sub warn_literal { |
599
|
|
|
|
|
|
|
my $self = shift; |
600
|
|
|
|
|
|
|
$self->vent_literal(_prepend 'warning:', @_); |
601
|
|
|
|
|
|
|
} |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
1; |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
__END__ |
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
=head1 Name |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
App::Sqitch - Sensible database change management |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
=head1 Synopsis |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
use App::Sqitch; |
614
|
|
|
|
|
|
|
exit App::Sqitch->go; |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
=head1 Description |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
This module provides the implementation for L<sqitch>. You probably want to |
619
|
|
|
|
|
|
|
read L<its documentation|sqitch>, or L<the tutorial|sqitchtutorial>. Unless |
620
|
|
|
|
|
|
|
you want to hack on Sqitch itself, or provide support for a new engine or |
621
|
|
|
|
|
|
|
L<command|Sqitch::App::Command>. In which case, you will find this API |
622
|
|
|
|
|
|
|
documentation useful. |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
=head1 Interface |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
=head2 Class Methods |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
=head3 C<go> |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
App::Sqitch->go; |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
Called from C<sqitch>, this class method parses command-line options and |
633
|
|
|
|
|
|
|
arguments in C<@ARGV>, parses the configuration file, constructs an |
634
|
|
|
|
|
|
|
App::Sqitch object, constructs a command object, and runs it. |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
=head2 Constructor |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
=head3 C<new> |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
my $sqitch = App::Sqitch->new(\%params); |
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
Constructs and returns a new Sqitch object. The supported parameters include: |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
=over |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
=item C<options> |
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
=item C<user_name> |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
=item C<user_email> |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
=item C<editor> |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
=item C<verbosity> |
655
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
=back |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
=head2 Accessors |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
=head3 C<user_name> |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
=head3 C<user_email> |
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
=head3 C<editor> |
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
=head3 C<options> |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
my $options = $sqitch->options; |
669
|
|
|
|
|
|
|
|
670
|
|
|
|
|
|
|
Returns a hashref of the core command-line options. |
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
=head3 C<config> |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
my $config = $sqitch->config; |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
Returns the full configuration, combined from the project, user, and system |
677
|
|
|
|
|
|
|
configuration files. |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
=head3 C<verbosity> |
680
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
=head2 Instance Methods |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
=head3 C<run> |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
$sqitch->run('echo', '-n', 'hello'); |
686
|
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
Runs a system command and waits for it to finish. Throws an exception on |
688
|
|
|
|
|
|
|
error. Does not use the shell, so arguments must be passed as a list. Use |
689
|
|
|
|
|
|
|
C<shell> to run a command and its arguments as a single string. |
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
=over |
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
=item C<target> |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
The name of the target, as passed. |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
=item C<uri> |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
A L<database URI|URI::db> object, to be used to connect to the target |
700
|
|
|
|
|
|
|
database. |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
=item C<registry> |
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
The name of the Sqitch registry in the target database. |
706
|
|
|
|
|
|
|
|
707
|
|
|
|
|
|
|
=back |
708
|
|
|
|
|
|
|
|
709
|
|
|
|
|
|
|
If the C<$target> argument looks like a database URI, it will simply returned |
710
|
|
|
|
|
|
|
in the hash reference. If the C<$target> argument corresponds to a target |
711
|
|
|
|
|
|
|
configuration key, the target configuration will be returned, with the C<uri> |
712
|
|
|
|
|
|
|
value a upgraded to a L<URI> object. Otherwise returns C<undef>. |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
=head3 C<shell> |
715
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
$sqitch->shell('echo -n hello'); |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
Shells out a system command and waits for it to finish. Throws an exception on |
719
|
|
|
|
|
|
|
error. Always uses the shell, so a single string must be passed encapsulating |
720
|
|
|
|
|
|
|
the entire command and its arguments. Use C<quote_shell> to assemble strings |
721
|
|
|
|
|
|
|
into a single shell command. Use C<run> to execute a list without a shell. |
722
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
=head3 C<quote_shell> |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
my $cmd = $sqitch->quote_shell('echo', '-n', 'hello'); |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
Assemble a list into a single string quoted for execution by C<shell>. Useful |
728
|
|
|
|
|
|
|
for combining a specified command, such as C<editor()>, which might include |
729
|
|
|
|
|
|
|
the options in the string, for example: |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
$sqitch->shell( $sqitch->editor, $sqitch->quote_shell($file) ); |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
=head3 C<capture> |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
my @files = $sqitch->capture(qw(ls -lah)); |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
Runs a system command and captures its output to C<STDOUT>. Returns the output |
738
|
|
|
|
|
|
|
lines in list context and the concatenation of the lines in scalar context. |
739
|
|
|
|
|
|
|
Throws an exception on error. |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
=head3 C<probe> |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
my $git_version = $sqitch->capture(qw(git --version)); |
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
Like C<capture>, but returns just the C<chomp>ed first line of output. |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
=head3 C<spool> |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
$sqitch->spool($sql_file_handle, 'sqlite3', 'my.db'); |
750
|
|
|
|
|
|
|
$sqitch->spool(\@file_handles, 'sqlite3', 'my.db'); |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
Like run, but spools the contents of one or ore file handle to the standard |
753
|
|
|
|
|
|
|
input the system command. Returns true on success and throws an exception on |
754
|
|
|
|
|
|
|
failure. |
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
=head3 C<trace> |
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
=head3 C<trace_literal> |
759
|
|
|
|
|
|
|
|
760
|
|
|
|
|
|
|
$sqitch->trace_literal('About to fuzzle the wuzzle.'); |
761
|
|
|
|
|
|
|
$sqitch->trace('Done.'); |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
Send trace information to C<STDOUT> if the verbosity level is 3 or higher. |
764
|
|
|
|
|
|
|
Trace messages will have C<trace: > prefixed to every line. If it's lower than |
765
|
|
|
|
|
|
|
3, nothing will be output. C<trace> appends a newline to the end of the |
766
|
|
|
|
|
|
|
message while C<trace_literal> does not. |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
=head3 C<debug> |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
=head3 C<debug_literal> |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
$sqitch->debug('Found snuggle in the crib.'); |
773
|
|
|
|
|
|
|
$sqitch->debug_literal('ITYM "snuggie".'); |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
Send debug information to C<STDOUT> if the verbosity level is 2 or higher. |
776
|
|
|
|
|
|
|
Debug messages will have C<debug: > prefixed to every line. If it's lower than |
777
|
|
|
|
|
|
|
2, nothing will be output. C<debug> appends a newline to the end of the |
778
|
|
|
|
|
|
|
message while C<debug_literal> does not. |
779
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
=head3 C<info> |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
=head3 C<info_literal> |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
$sqitch->info('Nothing to deploy (up-to-date)'); |
785
|
|
|
|
|
|
|
$sqitch->info_literal('Going to frobble the shiznet.'); |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
Send informational message to C<STDOUT> if the verbosity level is 1 or higher, |
788
|
|
|
|
|
|
|
which, by default, it is. Should be used for normal messages the user would |
789
|
|
|
|
|
|
|
normally want to see. If verbosity is lower than 1, nothing will be output. |
790
|
|
|
|
|
|
|
C<info> appends a newline to the end of the message while C<info_literal> does |
791
|
|
|
|
|
|
|
not. |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
=head3 C<comment> |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
=head3 C<comment_literal> |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
$sqitch->comment('On database flipr_test'); |
798
|
|
|
|
|
|
|
$sqitch->comment_literal('Uh-oh...'); |
799
|
|
|
|
|
|
|
|
800
|
|
|
|
|
|
|
Send comments to C<STDOUT> if the verbosity level is 1 or higher, which, by |
801
|
|
|
|
|
|
|
default, it is. Comments have C<# > prefixed to every line. If verbosity is |
802
|
|
|
|
|
|
|
lower than 1, nothing will be output. C<comment> appends a newline to the end |
803
|
|
|
|
|
|
|
of the message while C<comment_literal> does not. |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
=head3 C<emit> |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
=head3 C<emit_literal> |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
$sqitch->emit('core.editor=emacs'); |
810
|
|
|
|
|
|
|
$sqitch->emit_literal('Getting ready...'); |
811
|
|
|
|
|
|
|
|
812
|
|
|
|
|
|
|
Send a message to C<STDOUT>, without regard to the verbosity. Should be used |
813
|
|
|
|
|
|
|
only if the user explicitly asks for output, such as for C<sqitch config --get |
814
|
|
|
|
|
|
|
core.editor>. C<emit> appends a newline to the end of the message while |
815
|
|
|
|
|
|
|
C<emit_literal> does not. |
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
=head3 C<vent> |
818
|
|
|
|
|
|
|
|
819
|
|
|
|
|
|
|
=head3 C<vent_literal> |
820
|
|
|
|
|
|
|
|
821
|
|
|
|
|
|
|
$sqitch->vent('That was a misage.'); |
822
|
|
|
|
|
|
|
$sqitch->vent_literal('This is going to be bad...'); |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
Send a message to C<STDERR>, without regard to the verbosity. Should be used |
825
|
|
|
|
|
|
|
only for error messages to be printed before exiting with an error, such as |
826
|
|
|
|
|
|
|
when reverting failed changes. C<vent> appends a newline to the end of the |
827
|
|
|
|
|
|
|
message while C<vent_literal> does not. |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
=head3 C<page> |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
=head3 C<page_literal> |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
$sqitch->page('Search results:'); |
834
|
|
|
|
|
|
|
$sqitch->page("Here we go\n"); |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
Like C<emit()>, but sends the output to a pager handle rather than C<STDOUT>. |
837
|
|
|
|
|
|
|
Unless there is no TTY (such as when output is being piped elsewhere), in |
838
|
|
|
|
|
|
|
which case it I<is> sent to C<STDOUT>. C<page> appends a newline to the end of |
839
|
|
|
|
|
|
|
the message while C<page_literal> does not. Meant to be used to send a lot of |
840
|
|
|
|
|
|
|
data to the user at once, such as when display the results of searching the |
841
|
|
|
|
|
|
|
event log: |
842
|
|
|
|
|
|
|
|
843
|
|
|
|
|
|
|
$iter = $engine->search_events; |
844
|
|
|
|
|
|
|
while ( my $change = $iter->() ) { |
845
|
|
|
|
|
|
|
$sqitch->page(join ' - ', @{ $change }{ qw(change_id event change) }); |
846
|
|
|
|
|
|
|
} |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
=head3 C<warn> |
849
|
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
=head3 C<warn_literal> |
851
|
|
|
|
|
|
|
|
852
|
|
|
|
|
|
|
$sqitch->warn('Could not find nerble; using nobble instead.'); |
853
|
|
|
|
|
|
|
$sqitch->warn_literal("Cannot read file: $!\n"); |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
Send a warning messages to C<STDERR>. Warnings will have C<warning: > prefixed |
856
|
|
|
|
|
|
|
to every line. Use if something unexpected happened but you can recover from |
857
|
|
|
|
|
|
|
it. C<warn> appends a newline to the end of the message while C<warn_literal> |
858
|
|
|
|
|
|
|
does not. |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
=head3 C<prompt> |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
my $ans = $sqitch->('Why would you want to do this?', 'because'); |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
Prompts the user for input and returns that input. Pass in an optional default |
865
|
|
|
|
|
|
|
value for the user to accept or to be used if Sqitch is running unattended. An |
866
|
|
|
|
|
|
|
exception will be thrown if there is no prompt message or if Sqitch is |
867
|
|
|
|
|
|
|
unattended and there is no default value. |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
=head3 C<ask_yes_no> |
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
if ( $sqitch->ask_yes_no('Are you sure?', 1) ) { # do it! } |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
Prompts the user with a "yes" or "no" question. Returns true if the user |
874
|
|
|
|
|
|
|
replies in the affirmative and false if the reply is in the negative. If the |
875
|
|
|
|
|
|
|
optional second argument is passed and true, the answer will default to the |
876
|
|
|
|
|
|
|
affirmative. If the second argument is passed but false, the answer will |
877
|
|
|
|
|
|
|
default to the negative. When a translation library is in use, the affirmative |
878
|
|
|
|
|
|
|
and negative replies from the user should be localized variants of "yes" and |
879
|
|
|
|
|
|
|
"no", and will be matched as such. If no translation library is in use, the |
880
|
|
|
|
|
|
|
answers will default to the English "yes" and "no". |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
If the user inputs an invalid value three times, an exception will be thrown. |
883
|
|
|
|
|
|
|
An exception will also be thrown if there is no message. As with C<prompt()>, |
884
|
|
|
|
|
|
|
an exception will be thrown if Sqitch is running unattended and there is no |
885
|
|
|
|
|
|
|
default. |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
=head3 C<ask_y_n> |
888
|
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
This method has been deprecated in favor of C<ask_yes_no()> and will be |
890
|
|
|
|
|
|
|
removed in a future version of Sqitch. |
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
|
893
|
|
|
|
|
|
|
=head2 Constants |
894
|
|
|
|
|
|
|
|
895
|
|
|
|
|
|
|
=head3 C<ISWIN> |
896
|
|
|
|
|
|
|
|
897
|
|
|
|
|
|
|
my $app = 'sqitch' . ( ISWIN ? '.bat' : '' ); |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
True when Sqitch is running on Windows, and false when it's not. |
900
|
|
|
|
|
|
|
|
901
|
|
|
|
|
|
|
=head1 Author |
902
|
|
|
|
|
|
|
|
903
|
|
|
|
|
|
|
David E. Wheeler <david@justatheory.com> |
904
|
|
|
|
|
|
|
|
905
|
|
|
|
|
|
|
=head1 License |
906
|
|
|
|
|
|
|
|
907
|
|
|
|
|
|
|
Copyright (c) 2012-2023 iovation Inc., David E. Wheeler |
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
Permission is hereby granted, free of charge, to any person obtaining a copy |
910
|
|
|
|
|
|
|
of this software and associated documentation files (the "Software"), to deal |
911
|
|
|
|
|
|
|
in the Software without restriction, including without limitation the rights |
912
|
|
|
|
|
|
|
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell |
913
|
|
|
|
|
|
|
copies of the Software, and to permit persons to whom the Software is |
914
|
|
|
|
|
|
|
furnished to do so, subject to the following conditions: |
915
|
|
|
|
|
|
|
|
916
|
|
|
|
|
|
|
The above copyright notice and this permission notice shall be included in all |
917
|
|
|
|
|
|
|
copies or substantial portions of the Software. |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR |
920
|
|
|
|
|
|
|
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, |
921
|
|
|
|
|
|
|
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE |
922
|
|
|
|
|
|
|
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER |
923
|
|
|
|
|
|
|
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, |
924
|
|
|
|
|
|
|
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE |
925
|
|
|
|
|
|
|
SOFTWARE. |
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
=cut |