use
version;
our
$VERSION
= qv(
sprintf
'0.8.%d'
,
q$Rev: 206 $
=~ /\d+/gmx );
if
(
$ENV
{AUTOMATED_TESTING}) {
$ENV
{PERL_TEST_CRITIC} = FALSE;
$ENV
{PERL_TEST_POD} = FALSE;
$ENV
{TEST_CRITIC } = FALSE;
$ENV
{TEST_POD } = FALSE;
}
my
%CONFIG
=
(
changes_file
=>
q(Changes)
,
change_token
=>
q({{ $NEXT }})
,
config_attrs
=> {
storage_class
=>
q(JSON)
},
config_file
=> [
qw(var etc build.json)
],
create_ugrps
=> TRUE,
edit_files
=> TRUE,
install
=> TRUE,
license_file
=>
q(LICENSE)
,
line_format
=>
q(%-9s %s)
,
local_lib
=>
q(local)
,
manifest_file
=>
q(MANIFEST)
,
meta_keys
=> {
perl
=>
'Perl_5'
,
apache
=> [
map
{
"Apache_$_"
}
qw(1_1 2_0)
],
artistic
=>
'Artistic_1_0'
,
artistic_2
=>
'Artistic_2_0'
,
lgpl
=> [
map
{
"LGPL_$_"
}
qw(2_1 3_0)
],
bsd
=>
'BSD'
,
gpl
=> [
map
{
"GPL_$_"
}
qw(1 2 3)
],
mit
=>
'MIT'
,
mozilla
=> [
map
{
"Mozilla_$_"
}
qw(1_0 1_1)
], },
path_prefix
=> [ NUL,
qw(opt)
],
phase
=> 1,
pwidth
=> 50,
time_format
=>
q(%Y-%m-%d %T %Z)
, );
sub
ACTION_distmeta {
my
$self
=
shift
;
my
$cfg
;
try
{
$cfg
=
$self
->_get_config;
$self
->notes->{create_readme_pod} and podselect( {
-output
=>
q(README.pod)
},
$self
->dist_version_from );
$self
->_update_changelog(
$cfg
,
$self
->_dist_version );
}
catch
{
$self
->cli->fatal(
$_
) };
$self
->
next
::method();
try
{
$self
->_write_license_file(
$cfg
) }
catch
{
$self
->cli->fatal(
$_
) };
return
;
}
sub
ACTION_install {
my
$self
=
shift
;
my
$cfg
;
try
{
$cfg
=
$self
->_get_config;
$self
->_ask_questions(
$cfg
);
$self
->_set_install_paths(
$cfg
);
}
catch
{
$self
->cli->fatal(
$_
) };
$cfg
->{install} and
$self
->
next
::method();
try
{
my
$install
=
$self
->_install_actions_class->new(
builder
=>
$self
);
$install
->
$_
(
$cfg
)
for
(
grep
{
$cfg
->{
$_
} } @{
$install
->actions });
$self
->cli_info(
'Installation complete'
);
$self
->_post_install(
$cfg
);
}
catch
{
$self
->cli->fatal(
$_
) };
return
;
}
sub
ACTION_change_version {
my
$self
=
shift
;
try
{
$self
->depends_on(
q(manifest)
);
$self
->depends_on(
q(release)
);
$self
->_change_version(
$self
->_get_config );
}
catch
{
$self
->cli->fatal(
$_
) };
return
;
}
sub
ACTION_install_local_cpanm {
my
$self
=
shift
;
try
{
$self
->depends_on(
q(install_local_lib)
);
$self
->_install_local_cpanm(
$self
->_get_local_config );
}
catch
{
$self
->cli->fatal(
$_
) };
return
;
}
sub
ACTION_install_local_deps {
my
$self
=
shift
;
try
{
my
$cfg
=
$self
->_get_local_config;
$ENV
{DEVEL_COVER_NO_COVERAGE} = TRUE;
$ENV
{SITEPREFIX} =
$cfg
->{perlbrew_root};
$self
->depends_on(
q(install_local_cpanm)
);
$self
->_install_local_deps(
$cfg
);
}
catch
{
$self
->cli->fatal(
$_
) };
return
;
}
sub
ACTION_install_local_lib {
my
$self
=
shift
;
try
{
my
$cfg
=
$self
->_get_local_config;
$self
->_install_local_lib(
$cfg
);
$self
->_import_local_env (
$cfg
);
}
catch
{
$self
->cli->fatal(
$_
) };
return
;
}
sub
ACTION_install_local_perl {
my
$self
=
shift
;
try
{
$self
->depends_on(
q(install_local_perlbrew)
);
$self
->_install_local_perl(
$self
->_get_local_config );
}
catch
{
$self
->cli->fatal(
$_
) };
return
;
}
sub
ACTION_install_local_perlbrew {
my
$self
=
shift
;
try
{
$self
->depends_on(
q(install_local_lib)
);
$self
->_install_local_perlbrew(
$self
->_get_local_config );
}
catch
{
$self
->cli->fatal(
$_
) };
return
;
}
sub
ACTION_local_archive {
my
$self
=
shift
;
try
{
my
$dir
=
$self
->_get_config->{local_lib};
$self
->make_tarball(
$dir
,
$self
->_get_archive_names(
$dir
)->[ 0 ] );
}
catch
{
$self
->cli->fatal(
$_
) };
return
;
}
sub
ACTION_prereq_diff {
my
$self
=
shift
;
try
{
$self
->_prereq_diff(
$self
->_get_config ) }
catch
{
$self
->cli->fatal(
$_
) };
return
;
}
sub
ACTION_release {
my
$self
=
shift
;
try
{
$self
->depends_on(
q(distmeta)
);
$self
->_commit_release(
'release '
.
$self
->_dist_version ) }
catch
{
$self
->cli->fatal(
$_
) };
return
;
}
sub
ACTION_restore_local_archive {
my
$self
=
shift
;
try
{
my
$dir
=
$self
->_get_config->{local_lib};
$self
->_extract_tarball(
$self
->_get_archive_names(
$dir
) );
}
catch
{
$self
->cli->fatal(
$_
) };
return
;
}
sub
ACTION_standalone {
my
$self
=
shift
;
try
{
$self
->depends_on(
q(install_local_deps)
);
$self
->depends_on(
q(manifest)
);
$self
->depends_on(
q(dist)
);
}
catch
{
$self
->cli->fatal(
$_
) };
return
;
}
sub
ACTION_uninstall {
my
$self
=
shift
;
try
{
my
$cfg
=
$self
->_get_config;
$self
->_set_install_paths(
$cfg
);
$self
->_uninstall(
$cfg
);
}
catch
{
$self
->cli->fatal(
$_
) };
return
;
}
sub
ACTION_upload {
my
$self
=
shift
;
try
{
$self
->depends_on(
q(release)
);
$self
->depends_on(
q(dist)
);
$self
->_cpan_upload;
}
catch
{
$self
->cli->fatal(
$_
) };
return
;
}
sub
class_path {
return
catfile(
q(lib)
,
split
m{ :: }mx,
$_
[ 1 ].
q(.pm)
);
}
sub
cli {
state
$cache
;
return
$cache
||= Class::Usul::Programs->new
(
appclass
=>
$_
[ 0 ]->module_name,
nodebug
=> TRUE );
}
sub
cli_info {
return
shift
->cli->info(
map
{
chomp
;
"${_}\n"
} @{ [
@_
] } );
}
sub
dispatch {
my
$self
=
shift
;
$self
->_setup_plugins;
return
$self
->
next
::method(
@_
);
}
sub
distname {
my
$distname
=
$_
[ 1 ];
$distname
=~ s{ :: }{-}gmx;
return
$distname
;
}
sub
make_tarball {
my
(
$self
,
$dir
,
$archive
) =
@_
;
$archive
||=
$dir
;
return
$self
->
next
::method(
$dir
,
$self
->_archive_file(
$archive
) );
}
sub
patch_file {
my
(
$self
,
$path
,
$patch
) =
@_
;
my
$cli
=
$self
->cli;
(not
$path
->is_file or -f
$path
.
q(.orig)
) and
return
;
$self
->cli_info(
"Patching ${path}"
);
$path
->copy(
$path
.
q(.orig)
);
my
$cmd
= [
qw(patch -p0)
,
$path
->pathname,
$patch
->pathname ];
$self
->cli_info(
$cli
->run_cmd(
$cmd
, {
err
=>
q(out)
} )->out );
return
;
}
sub
process_files {
my
(
$self
,
$src
,
$dest
) =
@_
;
$src
or
return
;
$dest
||=
q(blib)
;
if
(-f
$src
) {
$self
->_copy_file(
$src
,
$dest
) }
elsif
(-d
$src
) {
my
$prefix
=
$self
->base_dir;
find( {
no_chdir
=> TRUE,
wanted
=>
sub
{
(
my
$path
=
$File::Find::name
) =~ s{ \A
$prefix
}{}mx;
return
$self
->_copy_file(
$path
,
$dest
);
}, },
$src
);
}
return
;
}
sub
process_local_files {
my
$self
=
shift
;
return
$self
->process_files(
q(local)
);
}
sub
public_repository {
my
$class
=
shift
;
my
$repo
=
$class
->repository or
return
;
return
$repo
!~ m{ \A file: }mx ?
$repo
:
undef
;
}
sub
repository {
my
$vcs
=
shift
->_vcs or
return
;
return
$vcs
->repository;
}
sub
skip_pattern {
my
(
$self
,
$re
) =
@_
;
defined
$re
and
$self
->{_skip_pattern} =
$re
;
return
$self
->{_skip_pattern};
}
sub
_archive_dir {
return
updir();
}
sub
_archive_file {
return
catfile(
$_
[ 0 ]->_archive_dir,
$_
[ 1 ] );
}
sub
_ask_questions {
my
(
$self
,
$cfg
) =
@_
;
$cfg
->{built} and
return
;
my
$cli
=
$self
->cli;
$cli
->pwidth(
$cfg
->{pwidth} );
my
$quiz
=
$self
->_question_class->new(
builder
=>
$self
);
for
my
$attr
(@{
$quiz
->config_attributes }) {
my
$question
=
q(q_)
.
$attr
;
$cfg
->{
$attr
} =
$quiz
->
$question
(
$cfg
);
}
my
$args
= {
data
=>
$cfg
,
path
=>
$self
->_get_config_path(
$cfg
) };
$cli
->file->dataclass_schema(
$cfg
->{config_attrs} )->
dump
(
$args
);
return
;
}
sub
_change_version {
my
(
$self
,
$cfg
) =
@_
;
my
$cli
=
$self
->cli;
my
$comp
=
$cli
->get_line(
'Enter major/minor 0 or 1'
, 1, TRUE, 0 );
my
$bump
=
$cli
->get_line(
'Enter increment/decrement'
, 0, TRUE, 0 )
or
return
;
my
$ver
=
$self
->_dist_version or
return
;
my
$from
= __tag_from_version(
$ver
);
$ver
->component(
$comp
,
$ver
->component(
$comp
) +
$bump
);
$comp
== 0 and
$ver
->component( 1, 0 );
$self
->_update_version(
$from
, __tag_from_version(
$ver
) );
$self
->_create_tag_release(
$from
);
$self
->_update_changelog(
$cfg
,
$ver
=
$self
->_dist_version );
$self
->_commit_release(
'first '
.__tag_from_version(
$ver
) );
$self
->_rebuild_build;
return
;
}
sub
_commit_release {
my
(
$self
,
$msg
) =
@_
;
my
$vcs
=
$self
->_vcs or
return
;
$vcs
->commit(
ucfirst
$msg
) and
say
"Committed ${msg}"
;
$vcs
->error and
say
@{
$vcs
->error };
return
;
}
sub
_consolidate {
my
(
$self
,
$used
) =
@_
;
my
(
%dists
,
%result
);
$self
->cli->ensure_class_loaded(
q(CPAN)
);
for
my
$used_key
(
keys
%{
$used
}) {
my
(
$curr_dist
,
$module
,
$used_dist
);
my
$try_module
=
$used_key
;
while
(
$curr_dist
= __dist_from_module(
$try_module
)
and (not
$used_dist
or
$curr_dist
->base_id eq
$used_dist
->base_id)) {
$module
=
$try_module
;
$used_dist
or
$used_dist
=
$curr_dist
;
$try_module
=~ m{ :: }mx or
last
;
$try_module
=~ s{ :: [^:]+ \z }{}mx;
}
unless
(
$module
) {
$result
{
$used_key
} =
$used
->{
$used_key
};
next
;
}
exists
$dists
{
$module
} and
next
;
$dists
{
$module
} =
$self
->_version_from_module(
$module
);
}
$result
{
$_
} =
$dists
{
$_
}
for
(
keys
%dists
);
return
\
%result
;
}
sub
_copy_file {
my
(
$self
,
$src
,
$dest
) =
@_
;
my
$cli
=
$self
->cli;
my
$pattern
=
$self
->skip_pattern;
(
$src
and -f
$src
and (not
$pattern
or
$src
!~
$pattern
)) or
return
;
my
$dir
= catdir(
$dest
, dirname(
$src
) );
-d
$dir
or
$cli
->io(
$dir
)->mkpath(
oct
q(02750)
);
copy(
$src
,
$dir
);
return
;
}
sub
_cpan_upload {
my
$self
=
shift
;
my
$cli
=
$self
->cli;
my
$args
=
$self
->_read_pauserc;
$args
->{subdir} =
lc
$self
->dist_name;
exists
$args
->{dry_run} or
$args
->{dry_run}
=
$cli
->yorn(
'Really upload to CPAN'
, FALSE, TRUE, 0 );
$cli
->ensure_class_loaded(
q(CPAN::Uploader)
);
CPAN::Uploader->upload_file(
$self
->dist_dir.
q(.tar.gz)
,
$args
);
return
;
}
sub
_create_tag_release {
my
(
$self
,
$tag
) =
@_
;
my
$vcs
=
$self
->_vcs or
return
;
say
"Creating tagged release v${tag}"
;
$vcs
->tag(
$tag
);
$vcs
->error and
say
@{
$vcs
->error };
return
;
}
sub
_dependencies {
my
(
$self
,
$paths
) =
@_
;
my
$used
= {};
for
my
$path
(@{
$paths
}) {
my
$lines
= __read_non_pod_lines(
$path
);
for
my
$line
(
split
m{ \n }mx,
$lines
) {
my
$modules
= __parse_depends_line(
$line
);
$modules
->[ 0 ] or
next
;
for
(@{
$modules
}) {
__looks_like_version(
$_
) and
$used
->{perl} =
$_
and
next
;
not
exists
$used
->{
$_
}
and
$used
->{
$_
} =
$self
->_version_from_module(
$_
);
}
}
}
return
$used
;
}
sub
_dist_version {
my
$self
=
shift
;
my
$info
= Module::Metadata->new_from_file(
$self
->dist_version_from );
return
Perl::Version->new(
$info
->version );
}
sub
_extract_tarball {
my
(
$self
,
$archives
) =
@_
;
my
$cli
=
$self
->cli;
for
my
$file
(
map
{
$self
->_archive_file(
$_
.
q(.tar.gz)
) } @{
$archives
}) {
unless
(-f
$file
) {
$cli
->info(
"Archive ${file} not found\n"
) }
else
{
$cli
->run_cmd( [
qw(tar -xzf)
,
$file
] );
$cli
->info (
"Extracted ${file}\n"
);
return
;
}
}
return
;
}
sub
_filter_dependents {
my
(
$self
,
$cfg
,
$used
) =
@_
;
my
$perl_version
=
$used
->{perl} ||
$self
->requires->{perl};
my
$core_modules
=
$Module::CoreList::version
{
$perl_version
};
my
$provides
=
$self
->cli->get_meta->provides;
return
$self
->_consolidate( {
map
{
$_
=>
$used
->{
$_
} }
grep
{ not
exists
$core_modules
->{
$_
} }
grep
{ not
exists
$provides
->{
$_
} }
keys
%{
$used
} } );
}
sub
_filter_build_requires_paths {
return
[
grep
{ m{ \.t \z }mx } @{
$_
[ 1 ] } ];
}
sub
_filter_configure_requires_paths {
return
[
grep
{
$_
eq
q(Build.PL)
} @{
$_
[ 1 ] } ];
}
sub
_filter_requires_paths {
return
[
grep
{ not m{ \.t \z }mx and
$_
ne
q(Build.PL)
} @{
$_
[ 1 ] } ];
}
sub
_get_archive_names {
my
(
$self
,
$original_dir
) =
@_
;
my
$name
=
$self
->dist_name;
my
$arch
=
$Config
{myarchname};
my
@archives
= (
join
q(-)
,
$name
,
$original_dir
,
$self
->args->{ARGV}->[ 0 ] ||
$self
->_dist_version,
$arch
);
my
$pattern
=
"${name} - ${original_dir} - (.+) - ${arch}"
;
my
$latest
= (
map
{
$_
->[ 1 ] }
sort
{
$a
->[ 0 ] <=>
$b
->[ 0 ] }
map
{ __to_version_and_filename(
$pattern
,
$_
) }
$self
->cli->io (
$self
->_archive_dir )
->filter(
sub
{ m{
$pattern
}msx } )
->all_files )[ -1 ];
$latest
and
push
@archives
,
$latest
;
return
\
@archives
;
}
sub
_get_config {
my
(
$self
,
$passed_cfg
) =
@_
; state
$cache
;
$cache
and
return
$cache
;
my
$cfg
= {
%CONFIG
, %{
$passed_cfg
|| {} }, %{
$self
->notes } };
my
$path
;
if
(
$path
=
$self
->_get_config_path(
$cfg
) and -f
$path
) {
my
$file
=
$self
->cli(
$cfg
)->file;
$cfg
=
$file
->dataclass_schema(
$cfg
->{config_attrs} )->load(
$path
);
}
return
$cache
=
$cfg
;
}
sub
_get_config_path {
my
(
$self
,
$cfg
) =
@_
;
return
catfile(
$self
->base_dir,
$self
->blib, @{
$cfg
->{config_file} } );
}
sub
_get_local_config {
my
$self
=
shift
; state
$cache
;
$cache
and
return
$cache
;
my
$cli
=
$self
->cli; (
my
$perl_ver
=
$PERL_VERSION
) =~ s{ \A v }{perl-}mx;
my
$argv
=
$self
->args->{ARGV};
my
$cfg
=
$self
->_get_config;
$cfg
->{perl_ver } =
$argv
->[ 0 ] ||
$perl_ver
;
$cfg
->{appldir } =
$argv
->[ 1 ] || NUL.
$cli
->config->appldir;
$cfg
->{perlbrew_root} = catdir (
$cfg
->{appldir},
$cfg
->{local_lib} );
$cfg
->{local_etc } = catdir (
$cfg
->{perlbrew_root},
q(etc)
);
$cfg
->{local_libperl} = catdir (
$cfg
->{perlbrew_root},
qw(lib perl5)
);
$cfg
->{perlbrew_bin } = catdir (
$cfg
->{perlbrew_root},
q(bin)
);
$cfg
->{perlbrew_cmnd} = catfile(
$cfg
->{perlbrew_bin },
q(perlbrew)
);
$cfg
->{local_lib_uri} =
join
SEP,
$cfg
->{cpan_authors},
$cfg
->{ll_author},
$cfg
->{ll_ver_dir}.
q(.tar.gz)
;
return
$cache
=
$cfg
;
}
sub
_import_local_env {
my
(
$self
,
$cfg
) =
@_
;
lib->
import
(
$cfg
->{local_libperl} );
require
local
::lib;
local
::lib->
import
(
$cfg
->{perlbrew_root} );
return
;
}
sub
_install_actions_class {
return
__PACKAGE__.
q(::InstallActions)
;
}
sub
_install_local_cpanm {
my
(
$self
,
$cfg
) =
@_
;
my
$cli
=
$self
->cli;
my
$path
= catfile(
$cfg
->{perlbrew_bin},
q(cpanm)
);
-f
$path
and
return
;
$self
->cli_info(
'Installing local copy of App::cpanminus...'
);
$cli
->run_cmd(
$cmd
.
$cfg
->{perlbrew_root} );
not -f
$path
and throw
"Failed to install App::cpanminus to ${path}"
;
return
;
}
sub
_install_local_deps {
my
(
$self
,
$cfg
) =
@_
;
my
$cli
=
$self
->cli;
my
$local_lib
=
$cfg
->{perlbrew_root} or throw
'Local lib not set'
;
$self
->cli_info(
"Installing dependencies to ${local_lib}..."
);
my
$cmd
= [
qw(cpanm -L)
,
$local_lib
,
qw(--installdeps .)
];
$cli
->run_cmd(
$cmd
, {
err
=>
q(stderr)
,
out
=>
q(stdout)
} );
my
$ref
;
$ref
=
$self
->can(
q(hook_local_deps)
) and
$self
->
$ref
(
$cfg
);
return
;
}
sub
_install_local_lib {
my
(
$self
,
$cfg
) =
@_
;
my
$cli
=
$self
->cli;
my
$dir
=
$cfg
->{ll_ver_dir}; -d
$cfg
->{local_lib} and
return
;
chdir
$cfg
->{appldir};
$self
->cli_info(
'Installing local::lib to '
.
$cfg
->{perlbrew_root} );
$cli
->run_cmd(
q(curl -s -L )
.
$cfg
->{local_lib_uri}.
q( | tar -xzf -)
);
(-d
$dir
and
chdir
$dir
) or throw
"Directory ${dir} cannot access"
;
my
$cmd
=
q(perl Makefile.PL --bootstrap=)
.
$cfg
->{perlbrew_root};
$cli
->run_cmd(
$cmd
.
q( --no-manpages)
);
$cli
->run_cmd(
q(make test)
);
$cli
->run_cmd(
q(make install)
);
chdir
$cfg
->{appldir};
$cli
->io(
$cfg
->{ll_ver_dir} )->rmtree;
return
;
}
sub
_install_local_perl {
my
(
$self
,
$cfg
) =
@_
;
my
$cli
=
$self
->cli;
unless
(__perlbrew_mirror_is_set(
$cfg
)) {
my
$cmd
=
"echo 'm\n"
.
$cfg
->{perl_mirror}.
"' | perlbrew mirror"
;
$self
->cli_info(
'Setting perlbrew mirror'
);
__run_perlbrew(
$cli
,
$cfg
,
$cmd
);
}
unless
(__perl_version_is_installed(
$cli
,
$cfg
)) {
$self
->cli_info(
'Installing '
.
$cfg
->{perl_ver}.
'...'
);
__run_perlbrew(
$cli
,
$cfg
,
q(perlbrew install )
.
$cfg
->{perl_ver} );
}
__run_perlbrew(
$cli
,
$cfg
,
q(perlbrew switch )
.
$cfg
->{perl_ver} );
return
;
}
sub
_install_local_perlbrew {
my
(
$self
,
$cfg
) =
@_
;
my
$cli
=
$self
->cli;
-f
$cfg
->{perlbrew_cmnd} and
return
;
$self
->cli_info(
'Installing local perlbrew...'
);
$cli
->run_cmd (
q(cpanm -L )
.
$cfg
->{perlbrew_root}.
q( App::perlbrew)
);
__run_perlbrew(
$cli
,
$cfg
,
q(perlbrew init)
);
$cli
->io ( [
$cfg
->{local_etc},
q(kshrc)
] )
->
print
( __local_kshrc_content(
$cfg
) );
my
$ref
;
$ref
=
$self
->can(
q(hook_local_perlbrew)
) and
$self
->
$ref
(
$cfg
);
return
;
}
sub
_post_install {
my
(
$self
,
$cfg
) =
@_
;
$cfg
->{post_install} and
$self
->_run_bin_cmd(
$cfg
,
q(post_install)
)
and
$self
->cli_info(
'Post install complete'
);
return
;
}
sub
_prereq_diff {
my
(
$self
,
$cfg
) =
@_
;
my
$field
=
$self
->args->{ARGV}->[ 0 ] ||
q(requires)
;
my
$filter
=
q(_filter_)
.
$field
.
q(_paths)
;
my
$prereqs
=
$self
->prereq_data->{
$field
};
my
$depends
=
$self
->_dependencies(
$self
->
$filter
(
$self
->_source_paths ) );
my
$used
=
$self
->_filter_dependents(
$cfg
,
$depends
);
__say_diffs( __compare_prereqs_with_used(
$field
,
$prereqs
,
$used
) );
return
;
}
sub
_question_class {
return
__PACKAGE__.
q(::Questions)
;
}
sub
_read_pauserc {
my
$self
=
shift
;
my
$cli
=
$self
->cli;
my
$dir
=
$ENV
{HOME} || File::Spec->curdir;
my
$args
= {};
for
(
$cli
->io( [
$dir
,
q(.pause)
] )->
chomp
->getlines) {
(
$_
and
$_
!~ m{ \A \s* \
my
(
$k
,
$v
) = m{ \A \s* (\w+) \s+ (.+) \z }mx;
exists
$args
->{
$k
} and throw
"Multiple enties for ${k}"
;
$args
->{
$k
} =
$v
;
}
return
$args
;
}
sub
_rebuild_build {
my
$self
=
shift
;
my
$cmd
= [
$EXECUTABLE_NAME
,
q(Build.PL)
];
$self
->cli->run_cmd(
$cmd
, {
err
=>
q(out)
} );
return
;
}
sub
_run_bin_cmd {
my
(
$self
,
$cfg
,
$key
) =
@_
;
my
$cli
=
$self
->cli;
my
$cmd
;
$cfg
and
ref
$cfg
eq HASH and
$key
and
$cmd
=
$cfg
->{
$key
.
q(_cmd)
}
or throw
"Command ${key} not found"
;
my
(
$prog
,
@args
) =
split
SPC,
$cmd
;
my
$bind
=
$self
->install_destination(
q(bin)
);
my
$path
=
$cli
->file->absolute(
$bind
,
$prog
);
-f
$path
or throw
"Path ${path} not found"
;
$cmd
=
join
SPC,
$path
,
@args
;
$self
->cli_info(
"Running ${cmd}"
);
$cli
->run_cmd(
$cmd
, {
err
=>
q(stderr)
,
out
=>
q(stdout)
} );
my
$ref
;
$ref
=
$self
->can(
q(hook_)
.
$key
) and
$self
->
$ref
(
$cfg
);
return
TRUE;
}
sub
_set_install_paths {
my
(
$self
,
$cfg
) =
@_
;
$cfg
->{base} or throw
'Config base path not set'
;
$self
->cli_info(
'Base path '
.
$cfg
->{base} );
$self
->install_base(
$cfg
->{base} );
$self
->install_path(
bin
=> catdir(
$cfg
->{base},
q(bin)
) );
$self
->install_path(
lib
=> catdir(
$cfg
->{base},
q(lib)
) );
$self
->install_path(
var
=> catdir(
$cfg
->{base},
q(var)
) );
$self
->install_path(
local
=> catdir(
$cfg
->{base},
q(local)
) );
return
;
}
sub
_setup_plugins {
state
$cache
;
return
$cache
||=
$_
[ 0 ]->cli->setup_plugins
( {
child_class
=> blessed
$_
[ 0 ],
search_paths
=> [
q(::Plugin::Build)
], } );
}
sub
_source_paths {
my
$self
=
shift
;
my
$cli
=
$self
->cli;
return
[
grep
{ __is_perl_script(
$cli
,
$_
) }
map
{ s{ \s+ }{ }gmx; (
split
SPC,
$_
)[ 0 ] }
$cli
->io(
$CONFIG
{manifest_file} )->
chomp
->getlines ];
}
sub
_uninstall {
my
(
$self
,
$cfg
) =
@_
;
$self
->_run_bin_cmd(
$cfg
,
q(uninstall)
)
and
$self
->cli_info(
'Uninstall complete'
);
return
;
}
sub
_update_changelog {
my
(
$self
,
$cfg
,
$ver
) =
@_
;
my
$io
=
$self
->cli->io(
$cfg
->{changes_file} );
my
$tok
=
$cfg
->{change_token};
my
$time
= time2str(
$cfg
->{time_format} || NUL );
my
$line
=
sprintf
$cfg
->{line_format},
$ver
->normal,
$time
;
my
$tag
=
q(v)
.__tag_from_version(
$ver
);
my
$text
=
$io
->all;
if
(
$text
=~ m{ ^ \Q
$tag
\E }mx) {
$text
=~ s{ ^ ( \Q
$tag
\E .* ) $ }{
$line
}mx }
else
{
$text
=~ s{ ( \Q
$tok
\E ) }{$1\n\n
$line
}mx }
say
'Updating '
.
$cfg
->{changes_file};
$io
->
close
->
print
(
$text
);
return
;
}
sub
_update_version {
my
(
$self
,
$from
,
$to
) =
@_
;
my
$cli
=
$self
->cli;
my
$prog
=
$EXECUTABLE_NAME
;
my
$cmd
=
$self
->notes->{version_pattern} or
return
;
$cmd
=~ s{ \$\{from\} }{
$from
}gmx;
$cmd
=~ s{ \$\{to\} }{
$to
}gmx;
$cmd
= [
q(xargs)
,
q(-i)
,
$prog
,
q(-pi)
,
q(-e)
,
"'"
.
$cmd
.
"'"
,
q({})
];
my
$paths
= [
map
{
"$_\n"
} @{
$self
->_source_paths } ];
$cli
->file->popen(
$cmd
, {
err
=>
q(out)
,
in
=>
$paths
} );
return
;
}
sub
_vcs {
my
$self
=
shift
; state
$cache
;
$cache
and
return
$cache
;
my
$is_blessed
= blessed
$self
? TRUE : FALSE;
my
$dir
=
$is_blessed
?
$self
->cli->config->appldir : File::Spec->curdir;
my
$vcs
=
$self
->_vcs_class->new(
project_dir
=>
$dir
);
return
$is_blessed
?
$cache
=
$vcs
:
$vcs
;
}
sub
_vcs_class {
return
__PACKAGE__.
q(::VCS)
;
}
sub
_version_from_module {
my
(
$self
,
$module
) =
@_
;
my
$version
;
eval
"no warnings; require ${module}; \$version = ${module}->VERSION;"
;
return
exception() || !
$version
?
undef
:
$version
;
}
sub
_write_license_file {
my
(
$self
,
$cfg
) =
@_
;
my
$cli
=
$self
->cli;
my
$license
=
$cfg
->{meta_keys}->{
$self
->license } or
return
;
$license
=
ref
$license
?
$license
->[ -1 ] :
$license
;
my
$class
=
q(Software::License::)
.
$license
;
$cli
->ensure_class_loaded(
$class
);
say
'Creating '
.
$cfg
->{license_file};
$license
=
$class
->new( {
holder
=>
$cli
->get_meta->author->[ 0 ] } );
$cli
->io(
$cfg
->{license_file} )->
print
(
$license
->fulltext );
return
;
}
sub
__compare_prereqs_with_used {
my
(
$field
,
$prereqs
,
$used
) =
@_
;
my
$result
= {};
my
$add_key
=
"Would add these to the ${field} in Build.PL"
;
my
$remove_key
=
"Would remove these from the ${field} in Build.PL"
;
my
$update_key
=
"Would update these in the ${field} in Build.PL"
;
for
(
grep
{
defined
$used
->{
$_
} }
keys
%{
$used
}) {
if
(
exists
$prereqs
->{
$_
}) {
my
$oldver
= version->new(
$prereqs
->{
$_
} );
my
$newver
= version->new(
$used
->{
$_
} );
if
(
$newver
!=
$oldver
) {
$result
->{
$update_key
}->{
$_
}
=
$prereqs
->{
$_
}.
q( => )
.
$used
->{
$_
};
}
}
else
{
$result
->{
$add_key
}->{
$_
} =
$used
->{
$_
} }
}
for
(
keys
%{
$prereqs
}) {
exists
$used
->{
$_
}
or
$result
->{
$remove_key
}->{
$_
} =
$prereqs
->{
$_
};
}
return
$result
;
}
sub
__dist_from_module {
my
$module
= CPAN::Shell->expand(
q(Module)
,
$_
[ 0 ] );
return
$module
?
$module
->distribution :
undef
;
}
sub
__draw_line {
return
say
q(-)
x (
$_
[ 0 ] || 60);
}
sub
__extract_statements_from {
my
$line
=
shift
;
return
grep
{
length
}
map
{ s{ \A \s+ }{}mx; s{ \s+ \z }{}mx;
$_
}
split
m{ ; }mx,
$line
;
}
sub
__is_perl_script {
my
(
$cli
,
$path
) =
@_
;
$path
=~ m{ (?: \.pm | \.t | \.pl ) \z }imx and
return
TRUE;
my
$line
=
$cli
->io(
$path
)->getline;
return
$line
=~ m{ \A \
}
sub
__local_kshrc_content {
my
$cfg
=
shift
;
my
$content
;
$content
=
'#!/usr/bin/env ksh'
.
"\n"
;
$content
.=
q(export LOCAL_LIB=)
.
$cfg
->{local_libperl}.
"\n"
;
$content
.=
q(export PERLBREW_ROOT=)
.
$cfg
->{perlbrew_root}.
"\n"
;
$content
.=
q(export PERLBREW_PERL=)
.
$cfg
->{perl_ver}.
"\n"
;
$content
.=
q(export PERLBREW_BIN=)
.
$cfg
->{perlbrew_bin}.
"\n"
;
$content
.=
q(export PERLBREW_CMND=)
.
$cfg
->{perlbrew_cmnd}.
"\n"
;
$content
.=
<<'RC';
perlbrew_set_path() {
alias -d perl 1>/dev/null
path_without_perlbrew=$(perl -e \
'print join ":", grep { index $_, $ENV{PERLBREW_ROOT} }
split m{ : }mx, $ENV{PATH};')
export PATH=${PERLBREW_BIN}:${path_without_perlbrew}
}
perlbrew() {
local rc ; export SHELL ; short_option=""
if [ $(echo ${1} | cut -c1) = '-' ]; then
short_option=${1} ; shift
fi
case "${1}" in
(use)
if [ -z "${2}" ]; then
print "Using ${PERLBREW_PERL} version"
elif [ -x ${PERLBREW_ROOT}/perls/${2}/bin/perl -o ${2} = system ]; then
unset PERLBREW_PERL
eval $(${PERLBREW_CMND} ${short_option} env ${2})
perlbrew_set_path
else
print "${2} is not installed" >&2 ; rc=1
fi
;;
(switch)
${PERLBREW_CMND} ${short_option} ${*} ; rc=${?}
test -n "$2" && perlbrew_set_path
;;
(off)
unset PERLBREW_PERL
${PERLBREW_CMND} ${short_option} off
perlbrew_set_path
;;
(*)
${PERLBREW_CMND} ${short_option} ${*} ; rc=${?}
;;
esac
alias -t -r
return ${rc:-0}
}
eval $(perl -I${LOCAL_LIB} -Mlocal::lib=${PERLBREW_ROOT})
perlbrew_set_path
RC
return
$content
;
}
sub
__looks_like_version {
my
$ver
=
shift
;
return
defined
$ver
&&
$ver
=~ m{ \A v? \d+ (?: \.[\d_]+ )? \z }mx;
}
sub
__parse_depends_line {
my
$line
=
shift
;
my
$modules
= [];
for
my
$stmt
(__extract_statements_from(
$line
)) {
if
(
$stmt
=~ m{ \A (?:
use
|
require
) \s+ }mx) {
my
(
undef
,
$module
,
$rest
) =
split
m{ \s+ }mx,
$stmt
, 3;
$module
=~ m{ \A (?: lib | strict | warnings ) \z }mx and
next
;
$module
=~ m{ [^\.:\w] }mx and
next
;
push
@{
$modules
},
$module
eq
q(base)
||
$module
eq
q(parent)
? (
$module
, __parse_list(
$rest
)) :
$module
;
}
elsif
(
$stmt
=~ m{ \A (?:
with
|
extends
) \s+ (.+) }mx) {
push
@{
$modules
}, __parse_list( $1 );
}
}
return
$modules
;
}
sub
__parse_list {
my
$string
=
shift
;
$string
=~ s{ \A
q w*
[\(/] \s* }{}mx;
$string
=~ s{ \s* [\)/] \z }{}mx;
$string
=~ s{ [\'\"] }{}gmx;
$string
=~ s{ , }{ }gmx;
return
grep
{
length
&& !m{ [^\.:\w] }mx }
split
m{ \s+ }mx,
$string
;
}
sub
__perl_version_is_installed {
my
(
$cli
,
$cfg
) =
@_
;
my
$perl_ver
=
$cfg
->{perl_ver};
my
$installed
= __run_perlbrew(
$cli
,
$cfg
,
q(perlbrew list)
)->out;
return
(
grep
{ m{
$perl_ver
}mx }
split
"\n"
,
$installed
)[0] ? TRUE : FALSE;
}
sub
__perlbrew_mirror_is_set {
return
-f catfile(
$_
[ 0 ]->{perlbrew_root},
q(Conf.pm)
);
}
sub
__read_non_pod_lines {
my
$path
=
shift
;
my
$p
= Pod::Eventual::Simple->read_file(
$path
);
return
join
"\n"
,
map
{
$_
->{content} }
grep
{
$_
->{type} eq
q(nonpod)
} @{
$p
};
}
sub
__run_perlbrew {
my
(
$cli
,
$cfg
,
$cmd
) =
@_
;
my
$path_sep
=
$Config::Config
{path_sep};
my
$path
=
join
$path_sep
,
grep
{
index
$_
,
$cfg
->{perlbrew_root} }
split
m{
$path_sep
}mx,
$ENV
{PATH};
$ENV
{PATH } =
$cfg
->{perlbrew_bin }.
$path_sep
.
$path
;
$ENV
{PERLBREW_ROOT} =
$cfg
->{perlbrew_root};
$ENV
{PERLBREW_PERL} =
$cfg
->{perl_ver };
return
$cli
->run_cmd(
$cmd
);
}
sub
__say_diffs {
my
$diffs
=
shift
; __draw_line();
for
my
$table
(
sort
keys
%{
$diffs
}) {
say
$table
; __draw_line();
for
(
sort
keys
%{
$diffs
->{
$table
} }) {
say
"'$_' => '"
.
$diffs
->{
$table
}->{
$_
}.
"',"
;
}
__draw_line();
}
return
;
}
sub
__tag_from_version {
my
$ver
=
shift
;
return
$ver
->component( 0 ).
q(.)
.
$ver
->component( 1 );
}
sub
__to_version_and_filename {
my
(
$pattern
,
$io
) =
@_
;
(
my
$file
=
$io
->filename) =~ s{ [.]tar[.]gz \z }{}msx;
my
(
$ver
) =
$file
=~ m{
$pattern
}msx;
return
[ qv(
$ver
),
$file
];
}
1;