use
5.010;
our
$VERSION
=
'v1.5.0'
;
requires
'command'
;
requires
'options'
;
requires
'configure'
;
requires
'sqitch'
;
requires
'extra_target_keys'
;
requires
'default_target'
;
has
properties
=> (
is
=>
'ro'
,
isa
=> HashRef,
default
=>
sub
{ {} },
);
around
options
=>
sub
{
my
(
$orig
,
$class
) =
@_
;
return
(
$class
->
$orig
), (
map
{
"$_=s"
}
$class
->extra_target_keys),
qw(
plan-file|f=s
registry=s
client=s
extension=s
top-dir=s
dir|d=s%
set|s=s%
)
;
};
around
configure
=>
sub
{
my
(
$orig
,
$class
,
$config
,
$opt
) =
@_
;
my
$props
= {};
for
my
$key
(
$class
->extra_target_keys,
qw(plan_file registry client extension top_dir dir)
) {
$props
->{
$key
} =
delete
$opt
->{
$key
}
if
exists
$opt
->{
$key
};
}
my
$params
=
$class
->
$orig
(
$config
,
$opt
);
if
(
my
$file
=
$props
->{plan_file} ) {
$props
->{plan_file} = file(
$file
)->cleanup;
}
if
(
my
$file
=
$props
->{top_dir} ) {
$props
->{top_dir} = dir(
$file
)->cleanup;
}
if
(
my
$uri
=
$props
->{uri} ) {
$props
->{uri} = URI->new(
$uri
);
}
if
(
my
$dirs
=
delete
$props
->{dir}) {
my
%ok_keys
=
map
{;
$_
=>
undef
} (
qw(reworked)
,
map
{ (
$_
,
"reworked_$_"
) }
qw(deploy revert verify)
);
my
@unknown
;
for
my
$key
(
keys
%{
$dirs
}) {
unless
(
exists
$ok_keys
{
$key
}) {
push
@unknown
=>
$key
;
next
;
}
$props
->{
"$key\_dir"
} = dir(
delete
$dirs
->{
$key
})->cleanup
}
if
(
@unknown
) {
hurl
$class
->
command
=> __nx(
'Unknown directory name: {dirs}'
,
'Unknown directory names: {dirs}'
,
@unknown
,
dirs
=>
join
(__
', '
,
sort
@unknown
),
);
}
}
if
(
my
$vars
=
$opt
->{set} ) {
$props
->{variables} =
$vars
;
}
$params
->{properties} =
$props
;
return
$params
;
};
sub
BUILD {
my
$self
=
shift
;
my
$props
=
$self
->properties;
if
(
my
$engine
=
$props
->{engine}) {
hurl
$self
->
command
=> __x(
'Unknown engine "{engine}"'
,
engine
=>
$engine
)
unless
first {
$engine
eq
$_
} App::Sqitch::Command::ENGINES;
}
if
(
my
$uri
=
$props
->{uri}) {
hurl
$self
->
command
=> __x(
'URI "{uri}" is not a database URI'
,
uri
=>
$uri
,
)
unless
eval
{
$uri
->isa(
'URI::db'
) };
my
$engine
=
$uri
->canonical_engine or hurl
$self
->
command
=> __x(
'No database engine in URI "{uri}"'
,
uri
=>
$uri
,
);
hurl
$self
->
command
=> __x(
'Unknown engine "{engine}" in URI "{uri}"'
,
engine
=>
$engine
,
uri
=>
$uri
,
)
unless
first {
$engine
eq
$_
} App::Sqitch::Command::ENGINES;
}
}
sub
config_target {
my
(
$self
,
%p
) =
@_
;
my
$sqitch
=
$self
->sqitch;
my
$props
=
$self
->properties;
my
@params
= (
sqitch
=>
$sqitch
);
if
(
my
$name
=
$p
{name} ||
$props
->{target}) {
push
@params
=> (
name
=>
$name
);
if
(
my
$uri
=
$p
{uri}) {
push
@params
=> (
uri
=>
$uri
);
}
else
{
my
$config
=
$sqitch
->config;
if
(
$name
!~ /:/ && !
$config
->get(
key
=>
"target.$name.uri"
)) {
my
$engine
=
$p
{engine} ||
$props
->{engine}
||
$config
->get(
key
=>
'core.engine'
)
|| hurl
$self
->
command
=> __(
'No engine specified; specify via target or core.engine'
);
push
@params
=> (
uri
=> URI::db->new(
"db:$engine:"
));
}
}
}
elsif
(
my
$engine
=
$p
{engine} ||
$props
->{engine}) {
my
$config
=
$sqitch
->config;
push
@params
=> (
name
=>
$config
->get(
key
=>
"engine.$engine.target"
)
||
$config
->get(
key
=>
'core.target'
)
||
"db:$engine:"
);
}
else
{
my
$default
=
$self
->default_target;
push
@params
=> (
name
=>
$default
->name,
uri
=>
$default
->uri,
);
}
return
App::Sqitch::Target->new(
@params
,
map
{
$_
=>
$props
->{
$_
} }
grep
{
$props
->{
$_
} }
qw(
top_dir
plan_file
registry
client
deploy_dir
revert_dir
verify_dir
reworked_dir
reworked_deploy_dir
reworked_revert_dir
reworked_verify_dir
extension
)
);
}
sub
directories_for {
my
$self
=
shift
;
my
$props
=
$self
->properties;
my
(
@dirs
,
%seen
);
for
my
$target
(
@_
) {
if
(
my
$top_dir
=
$props
->{top_dir}) {
push
@dirs
=>
grep
{ !
$seen
{
$_
}++ }
map
{
$props
->{
"$_\_$_"
} ||
$top_dir
->subdir(
$_
);
}
qw(deploy revert verify)
;
}
else
{
push
@dirs
=>
grep
{ !
$seen
{
$_
}++ }
map
{
my
$name
=
"$_\_dir"
;
$props
->{
$name
} ||
$target
->
$name
;
}
qw(deploy revert verify)
;
}
if
(
my
$reworked_dir
=
$props
->{reworked_dir} ||
$props
->{top_dir}) {
push
@dirs
=>
grep
{ !
$seen
{
$_
}++ }
map
{
$props
->{
"reworked_$_\_dir"
} ||
$reworked_dir
->subdir(
$_
);
}
qw(deploy revert verify)
;
}
else
{
push
@dirs
=>
grep
{ !
$seen
{
$_
}++ }
map
{
my
$name
=
"reworked_$_\_dir"
;
$props
->{
$name
} ||
$target
->
$name
;
}
qw(deploy revert verify)
;
}
}
return
@dirs
;
}
sub
make_directories_for {
my
$self
=
shift
;
$self
->mkdirs(
$self
->directories_for(
@_
) );
}
sub
mkdirs {
my
$self
=
shift
;
for
my
$dir
(
@_
) {
next
if
-d
$dir
;
my
$sep
= dir(
''
)->stringify;
$self
->info(__x(
'Created {file}'
,
file
=>
"$dir$sep"
))
if
make_path
$dir
, {
error
=> \
my
$err
};
if
(
my
$diag
=
shift
@{
$err
} ) {
my
(
$path
,
$msg
) = %{
$diag
};
hurl
$self
->
command
=> __x(
'Error creating {path}: {error}'
,
path
=>
$path
,
error
=>
$msg
,
)
if
$path
;
hurl
$self
->
command
=>
$msg
;
}
}
return
$self
;
}
sub
write_plan {
my
(
$self
,
%p
) =
@_
;
my
$project
=
$p
{project};
my
$uri
=
$p
{uri};
my
$target
=
$p
{target} ||
$self
->config_target;
my
$file
=
$target
->plan_file;
unless
(
$project
&&
$uri
) {
my
$conf_plan
=
$target
->plan;
my
$def_plan
=
$self
->default_target->plan;
if
(
try
{
$def_plan
->project }) {
$project
||=
$def_plan
->project;
$uri
||=
$def_plan
->uri;
}
elsif
(
try
{
$conf_plan
->project }) {
$project
||=
$conf_plan
->project;
$uri
||=
$conf_plan
->uri;
}
else
{
hurl
$self
->
command
=> __x(
'Missing %project pragma in {file}'
,
file
=>
$file
,
)
unless
$project
;
}
}
if
(-e
$file
) {
hurl
init
=> __x(
'Cannot initialize because {file} already exists and is not a file'
,
file
=>
$file
,
)
unless
-f
$file
;
my
$plan
= App::Sqitch::Plan->new(
sqitch
=>
$self
->sqitch,
file
=>
$file
,
target
=>
$target
,
);
my
$file_proj
=
try
{
$plan
->project } or hurl
init
=> __x(
'Cannot initialize because {file} already exists and is not a valid plan file'
,
file
=>
$file
,
);
hurl
init
=> __x(
'Cannot initialize because project "{project}" already initialized in {file}'
,
project
=>
$plan
->project,
file
=>
$file
,
)
if
$plan
->project ne
$project
;
return
$self
;
}
$self
->mkdirs(
$file
->dir )
unless
-d
$file
->dir;
my
$fh
=
$file
->
open
(
'>:utf8_strict'
) or hurl
init
=> __x(
'Cannot open {file}: {error}'
,
file
=>
$file
,
error
=> $!,
);
$fh
->
print
(
'%syntax-version='
, App::Sqitch::Plan::SYNTAX_VERSION(),
"\n"
,
'%project='
,
"$project\n"
,
(
$uri
? (
'%uri='
,
$uri
->canonical,
"\n"
) : () ),
"\n"
,
);
$fh
->
close
or hurl
add
=> __x(
'Error closing {file}: {error}'
,
file
=>
$file
,
error
=> $!
);
$self
->sqitch->info( __x
'Created {file}'
,
file
=>
$file
);
return
$self
;
}
sub
config_params {
my
(
$self
,
$key
) =
@_
;
my
@vars
;
while
(
my
(
$prop
,
$val
) =
each
%{
$self
->properties } ) {
if
(
ref
$val
eq
'HASH'
) {
push
@vars
=>
map
{{
key
=>
"$key.$prop.$_"
,
value
=>
$val
->{
$_
},
}}
keys
%{
$val
};
}
else
{
push
@vars
=> {
key
=>
"$key.$prop"
,
value
=>
$val
,
};
}
}
return
\
@vars
;
}
1;