#!/usr/local/bin/perl
eval
'exec /usr/local/bin/perl -S $0 ${1+"$@"}'
if
0;
use
5.006;
our
$VERSION
=
'0.51'
;
my
@extuse
;
BEGIN {
@extuse
=
qw(App::Rad IPC::Cmd IO::Scalar Devel::Platform::Info Devel::PatchPerl)
;
if
($^O !~ /^linux|freebsd|darwin|solaris|openbsd|cygwin$/) {
if
($^O =~ /^vms|dos|bsdos$/) {
die
"unsupported OS $^O"
;
}
elsif
($^O =~ /^MSWin32|msys/) {
warn
"$^O not yet fully supported\n"
;
}
else
{
warn
"untested OS $^O. Feedback welcome"
;
}
}
sub
_auto_use {
my
@m
;
for
(
@_
) {
push
@m
,
$_
unless
eval
"require $_;"
}
if
(
@m
) {
require
CPAN; CPAN->
import
;
warn
"CPAN::Shell->install(qw(@m))\n"
; CPAN::Shell->install(
@m
); }
$_
->
import
for
@m
;
}
_auto_use(
@extuse
);
}
our
@main_releases
=
qw(5.6.2 5.8.4 5.8.5 5.8.8 5.8.9 5.10.1 5.12.5 5.14.4 5.16.3
5.18.4 5.20.3 5.22.4 5.24.4 5.26.3 5.28.2 5.30.0)
;
push
@App::Rad::ISA
,
'main'
;
our
@opts
= (
[
"skip=s"
,
"skip versions (glob-style) or --skip=outdated"
],
[
"newer=s"
,
"only newer and same versions (glob-style)"
],
[
"older=s"
,
"only older versions (glob-style)"
],
[
"nogit"
,
"skip @ git versions"
],
[
"main|m"
,
"same as --skip=outdated"
],
[
"reverse|r"
,
"reverse, oldest first"
],
[
"quiet|q"
,
"no TEST_VERBOSE, no system >STDOUT"
],
[
"verbose|v"
,
"Make perlall command say more"
],
[
"dryrun!"
,
"do not execute commands, only print"
],
[
"nolog"
,
"skip writing log file(s)"
],
[
"list|l"
,
"shortcut for command list"
],
[
"help|h"
,
"print usage for commands and options"
],
[
"debug|d"
,
"lots of internal debugging output"
],
[
"gittag=s"
,
"for the testvm logfile"
],
[
"timeout=i"
,
"IPC::Cmd::run timeout in seconds, Default: 0"
],
[
"version|V"
]);
App::Rad->
import
(
'debug'
)
if
grep
/^-d$/,
@ARGV
;
App::Rad->run();
sub
setup {
$_
[0]->register_commands( {
-ignore_prefix
=>
'_'
} );
$_
[0]->register(
'install'
, \
&build
,
"alias to build"
);
$_
[0]->register(
'smoke'
, \
&build
,
"(NYI) smoke [ perl<version><suffix> branch ]"
);
$_
[0]->unregister(
'basename'
);
}
sub
App::Rad::Help::usage {
return
"\nUsage: "
.basename($0).
" [options] command [arguments]"
;
}
sub
pre_process {
my
$c
=
shift
;
my
$cmd
=
$c
->cmd;
$c
->config->{PERLALL_PREFIX} =
'/usr/local'
;
$c
->config->{PERLALL_BUILDROOT} =
'/usr/src/perl'
;
if
(
$cmd
eq
'init'
) {
$c
->config->{cpan} =
'cpan'
;
$c
->config->{
'init-modules'
} =
'YAML Clone DBI DBD::SQLite CPAN::SQLite Devel::Platform::Info'
.
' Params::Util Bundle::CPANReporter2 Math::Round Params::Classify Bundle::CygwinVendor'
.
' YAML::XS List::MoreUtils DBIx::Class SQL::Abstract Module::Find Mouse MouseX::Types Modern::Perl'
.
' Task::Kensho'
;
if
(basename(Cwd::getcwd) =~/^B-C/ and -f
"t/top100"
) {
_auto_use(
"File::Slurp"
);
$c
->config->{
'init-modules'
} .=
" "
.
join
(
" "
,File::Slurp::read_file(
"t/top100"
));
}
}
my
$sudo
= $^O =~ /cygwin|msys|MSWin32/ ?
""
:
"sudo"
;
$c
->config->{sudo} =
$sudo
;
if
($^O eq
'MSWin32'
) {
$ENV
{HOME} =
$ENV
{HOMEDRIVE} .
$ENV
{HOMEPATH}
unless
$ENV
{HOME};
$c
->config->{PERLALL_PREFIX} =
$Config
{prefix};
$c
->config->{PERLALL_BUILDROOT} =
$ENV
{HOME}.
"\\perl5"
;
if
(
$Config
{installsitebin} and
$Config
{installsitebin} =~
$ENV
{PATH}) {
$c
->config->{PERLALL_BINDIR} =
$Config
{installsitebin};
}
else
{
$c
->config->{PERLALL_BINDIR} =
$ENV
{HOME}.
"\\perl5\\bin"
;
}
}
if
(
$cmd
=~ /^build|config|uninstall|init|list|testvm|smoke|
do
|make.*$|cpan.*/) {
for
(
"/etc/perlall"
,
"$ENV{HOME}/.perlall"
) {
$c
->_dot_perlall(
$_
)
if
-f
$_
;
}
$c
->config->{PERLALL_PREFIX} =
'/usr/local'
unless
$c
->config->{PERLALL_PREFIX};
$c
->config->{PERLALL_BINDIR} =
$c
->config->{PERLALL_PREFIX}.
"/bin"
unless
$c
->config->{PERLALL_BINDIR};
$c
->config->{PERLALL_BUILDROOT} =
'/usr/src/perl'
unless
$c
->config->{PERLALL_BUILDROOT};
$c
->config->{
'perl-git'
} =
$c
->config->{PERLALL_BUILDROOT}.
'/blead/perl-git'
unless
$c
->config->{
'perl-git'
};
$c
->config->{
'cdcperl'
} =
$c
->config->{PERLALL_BUILDROOT}.
'/blead/cperl'
unless
$c
->config->{
'cdcperl'
};
$c
->config->{
'perlall_timeout'
} = 0
unless
$c
->config->{
'perlall_timeout'
};
if
(
$c
->is_command(
$cmd
) and
$cmd
!~ /^list/) {
my
$d
= Devel::Platform::Info->new->get_info();
my
$s
=
$d
->{oslabel};
my
$v
=
$d
->{osvers};
if
($^O eq
'solaris'
and !
$s
) {
$s
=
"solaris"
;
$v
=
$d
->{kvers}
if
$v
eq
'SunOS'
;
}
$v
=~ s/^\D*//;
$v
=~ s/[^\d\.]//g;
$s
=
$s
.
$v
;
$s
=~ s/[\s\(\)\[\}\[\]]//g;
if
($^O eq
'cygwin'
) {
$s
=
$d
->{source}->{uname}->[2];
$s
=~ s/\(.+$//;
$s
=
'cygwin'
.
$s
.
'_'
.
$d
->{source}->{uname}->[1];
}
$s
= $^O
unless
$s
;
if
(
$cmd
eq
'maketest'
) {
$c
->stash->{logprefix} =
"log.test-"
.
lc
(
$s
).
"-"
;
}
else
{
$c
->stash->{logprefix} =
"log.$cmd-"
.
lc
(
$s
).
"-"
;
}
$c
->_check_lock()
if
$cmd
=~ /^
do
|make/;
}
}
if
(
$cmd
=~ /^
do
|make.*|init|cpanm?|list|uninstall$/) {
my
@p
;
if
(
$c
->argv->[0] =~ /^(c?perl)?5\./ ) {
@p
= (
shift
@{
$c
->argv});
if
(
$p
[0] =~ /[\*\?\[]/) {
$p
[0] =~ s/^c?perl//;
@p
=
$c
->_get_perlall(
$p
[0]);
}
else
{
$p
[0] =~ s/^5\./perl5\./;
}
}
else
{
@p
=
$c
->_get_perlall();
}
$c
->stash->{perlall} = \
@p
;
}
}
sub
App::Rad::addopts {
my
$c
=
shift
;
my
$savopts
=
$c
->options;
my
@savargv
=
@ARGV
;
if
(
$c
->cmd =~ /^make|
do
/ and
$c
->cmd ne
'maketest'
) {
$c
->debug(
"pass some options verbatim through"
);
@ARGV
= ();
if
(
grep
{
$_
eq
'-v'
}
@savargv
) {
push
@ARGV
,
'-v'
;
}
}
$c
->getopt(
@_
);
$c
->options->{
$_
} =
$savopts
->{
$_
}
for
keys
%$savopts
;
@ARGV
=
@savargv
;
}
sub
App::Rad::_get_input {
my
$c
=
shift
;
die
"Getopt::Long needs to be version 2.36 or above"
unless
$Getopt::Long::VERSION
>= 2.36;
my
(
@options
,
@params
);
my
$base
= basename($0);
my
$cmd
;
if
(
$base
ne
'perlall'
) {
(
$cmd
) =
$base
=~ /perlall-(\w+)$/;
$c
->{
'cmd'
} =
$cmd
;
unless
(
$c
->is_command(
$cmd
)) {
warn
"invalid link $base: unknown Command $cmd\n"
;
return
;
}
$c
->config->{linked} =
$cmd
;
}
for
(
my
$i
=0;
$i
<
@ARGV
;
$i
++) {
if
(
defined
(
$ARGV
[
$i
]) and
substr
(
$ARGV
[
$i
], 0, 1) ne
'-'
) {
$c
->{
'cmd'
} =
$ARGV
[
$i
]
unless
$cmd
;
@params
= (
@ARGV
[
$i
..
$#ARGV
]);
shift
@params
unless
$c
->config->{linked};
last
;
}
push
@options
, (
$ARGV
[
$i
]);
}
@{
$c
->argv} = (
@params
);
$c
->{
'cmd'
} =
''
unless
$c
->{
'cmd'
};
my
$parser
= new Getopt::Long::Parser;
$parser
->configure(
qw(bundling)
);
@ARGV
=
@options
;
my
$ret
=
$parser
->getoptions(
$c
->{
'_options'
},
map
{
$_
->[0]}
@opts
);
$c
->options->{timeout} =
$c
->config->{perlall_timeout}
unless
exists
$c
->options->{timeout};
delete
$c
->options->{timeout}
unless
$c
->options->{timeout};
$c
->debug(
'received options: '
.
join
(
' '
,
@options
) .
' => '
. _opts(
$c
->options));
$c
->debug(
'received command: '
.
$c
->{
'cmd'
});
$c
->debug(
'received parameters: '
.
join
(
' '
, @{
$c
->argv} ));
@ARGV
= @{
$c
->argv};
if
(!
$c
->{
'cmd'
} and
$c
->options->{list}) {
$c
->execute(
'list'
);
$c
->{
'cmd'
} =
''
;
exit
;
}
if
(!
$c
->{
'cmd'
} and
$c
->options->{version}) {
return
$c
->version();
}
return
$c
;
}
sub
_get_perlall {
my
(
$c
,
$glob
) =
@_
;
my
$cperl
;
unless
(
$glob
) {
$glob
=
$ENV
{perlall} ?
$ENV
{perlall} :
"5.*"
;
}
if
(
$glob
=~ /^cperl/) {
$glob
=~ s/^cperl//;
$cperl
= 1;
}
elsif
(
$glob
=~ /^perl/) {
$glob
=~ s/^perl//;
$cperl
= -1;
}
die
"invalid version $glob"
if
$glob
!~ /^5\./ or
$glob
=~ /[!"';,\(\)]/;
my
$prefix
=
$c
->config->{PERLALL_BINDIR};
$prefix
=
"/usr/local/bin"
unless
$prefix
;
my
@p
;
my
$pathsep
= $^O eq
'MSWin32'
?
'\\'
:
'/'
;
my
$perl
=
"$prefix$pathsep"
.
"perl"
;
if
(
$c
->options->{dryrun} and
$ENV
{HARNESS_ACTIVE}) {
@p
=
map
{
"/usr/local/bin/perl$_"
}
qw(5.8.9d 5.12.1-nt 5.14.2 5.15.4@ababab)
;
}
else
{
if
(
$cperl
) {
@p
=
$cperl
== 1
?
glob
(
"$prefix$pathsep"
.
"cperl$glob"
)
:
glob
(
"$prefix$pathsep"
.
"perl$glob"
);
}
else
{
@p
= (
glob
(
"$prefix$pathsep"
.
"cperl$glob"
),
glob
(
"$perl$glob"
));
}
}
@p
=
grep
!/\.dSYM$/,
@p
if
$^O eq
'darwin'
;
my
%skip
;
if
(
$c
->options->{skip} or
$c
->options->{main}) {
if
(
$c
->options->{main} or
$c
->options->{skip} eq
'outdated'
) {
my
$srcdir
=
$c
->config->{
'perl-git'
};
if
(
$srcdir
and -d
$srcdir
and -d
"$srcdir/.git"
) {
my
$major
;
for
(
split
(/\n/,`git --git-dir=
"$srcdir/.git"
tag -l`)) {
my
(
$mj
,
$mi
) =
$_
=~ m/^(?:v|perl-)5\.(\d+)\.(\d+)$/;
push
@{
$major
->{
$mj
}},
$mi
if
$mj
and
$mj
% 2 == 0;
}
for
my
$mj
(
keys
%$major
) {
my
$max
= 0;
for
(@{
$major
->{
$mj
}}) {
$max
=
$_
if
$_
>
$max
; }
unless
(
grep
{
"5.$mj.$max"
eq
$_
}
@main_releases
) {
@main_releases
=
grep
!/^5\.
$mj
\.\d+/,
@main_releases
;
push
@main_releases
,
"5.$mj.$max"
;
}
}
}
if
(
$cperl
) {
my
$srcdir
=
$c
->config->{
'cdcperl'
};
if
(
$srcdir
and -d
$srcdir
and -d
"$srcdir/.git"
) {
my
$major
;
for
(
split
(/\n/,`git --git-dir=
"$srcdir/.git"
tag -l`)) {
my
(
$mj
,
$mi
) =
$_
=~ m/^cperl-5\.(\d+)\.(\d+)$/;
push
@{
$major
->{
$mj
}},
$mi
if
$mj
and
$mj
% 2 == 0;
}
for
my
$mj
(
keys
%$major
) {
my
$max
= 0;
for
(@{
$major
->{
$mj
}}) {
$max
=
$_
if
$_
>
$max
; }
unless
(
grep
{
"5.$mj.$max"
eq
$_
}
@main_releases
) {
@main_releases
=
grep
!/^5\.
$mj
\.\d+/,
@main_releases
;
push
@main_releases
,
"5.$mj.$max"
;
}
}
}
else
{
push
@main_releases
, (
"5.28.2"
,
"5.26.5"
,
"5.24.4"
,
"5.22.5"
);
$skip
{
'5.26.3'
}++;
$skip
{
'5.22.4'
}++;
}
}
my
@np
;
for
my
$p
(
grep
!/(\@|-asan|-nt-)/,
@p
) {
push
@np
,
map
{
index
(
$p
,
"perl$_"
)>=0 ?
$p
:()}
@main_releases
;
}
@p
=
@np
;
@np
= ();
for
my
$p
(
@p
) {
my
$nondbg
=
$p
;
$nondbg
=~ s/(\.\d)d/$1/;
if
(
$nondbg
ne
$p
) {
$skip
{
$p
}++
if
grep
{
$nondbg
eq
$_
}
@p
;
}
}
}
else
{
%skip
=
map
{
$_
=> 1}
glob
$perl
.
$c
->options->{skip};
}
}
@p
=
grep
!/(\@|-git)/,
@p
if
$c
->options->{nogit};
if
(
my
$ver
=
$c
->options->{older}) {
for
(
@p
) {
$skip
{
$_
}++
unless
$c
->_older(
$_
,
$ver
);
}
}
if
(
my
$ver
=
$c
->options->{newer}) {
for
(
@p
) {
$skip
{
$_
}++
if
$c
->_older(
$_
,
$ver
);
}
}
@p
=
grep
(!
$skip
{
$_
},
@p
)
if
%skip
;
@p
=
grep
{
(-l
$_
and (
readlink
(
$_
) =~ m|
$prefix
/c?perl5\..*|)) ? 0 :
$_
}
@p
;
if
(
$c
->options->{
reverse
}) {
sort
{ _strip2float(
$a
) <=> _strip2float(
$b
) }
@p
;
}
else
{
sort
{ _strip2float(
$b
) <=> _strip2float(
$a
) }
@p
;
}
}
sub
_opts {
my
$h
=
shift
;
my
$s
=
''
;
for
(
keys
%$h
) {
my
$v
=
$h
->{
$_
};
if
(
ref
(
$v
) eq
'ARRAY'
) {
for
my
$v
(@{
$h
->{
$_
}}) {
$s
.= (
$v
!= 1 ?
" --"
.
$_
.
"=$v"
:
" --"
.
$_
);
}
}
else
{
$s
.= (
$v
!= 1 ?
" --"
.
$_
.
"=$v"
:
" --"
.
$_
);
}
}
substr
(
$s
,1);
}
sub
_strip2float {
my
$p
=
shift
;
$p
=~ s/^.
*perl5
\.//;
$p
=~ s/^5\.//;
$p
=~ s/(\.\d+)\D.*$/$1/;
$p
}
sub
_older {
my
$c
=
shift
;
my
(
$p
,
$ver
) =
@_
;
$p
=~ s/^.
*perl5
\.//;
$p
=~ s/^5\.//;
$p
=~ s/(\.\d+)\D.*$/$1/;
$ver
=~ s/^5\.//;
$c
->debug(
"_older($_[0], $_[1]) => $p, $ver"
);
return
$p
<
$ver
;
}
sub
_dot_perlall {
my
(
$c
,
$filename
,
$write
) = (
@_
);
$c
->debug((
$write
?
"writing"
:
"loading"
).
" configuration from $filename"
);
open
my
$CONFIG
,
'<'
,
$filename
or Carp::croak
"error opening $filename: $!\n"
;
my
(
$s
,
$NEW
);
$write
=
undef
if
$c
->options->{dryrun};
if
(
$write
) {
open
$NEW
,
'>'
,
$filename
.
".tmp"
or Carp::croak
"error opening $filename.tmp: $!\n"
;
}
while
(<
$CONFIG
>) {
$s
=
$_
if
$write
;
chomp
;
s/
s/\s+$//;
print
$NEW
$s
if
$s
and !
length
;
next
unless
length
;
if
(/\\\s*$/) {
my
$t
=
''
;
do
{
s/\\\s*$//;
s/
chomp
;
$t
.=
$_
;
}
while
(
$_
= <
$CONFIG
> and
$_
=~ /\\\s*$/);
s/
chomp
;
$t
.=
$_
;
$_
=
$t
;
}
s/^\s+//;
if
( m/^alias\s([^\=\:\s]+)
(?:=[
'"]?) # ='
([^'"]+)
/x
) {
my
(
$k
,
$v
) = ($1, $2);
if
(
$k
eq
'perl-git'
) {
$v
=~ s/^cd //;
$c
->config->{
$k
} =
$v
;
$v
=
"cd "
.
$v
;
}
elsif
(
$k
eq
'cdcperl'
) {
$v
=~ s/^cd //;
$c
->config->{
$k
} =
$v
;
$v
=
"cd "
.
$v
;
}
else
{
$c
->config->{
$k
} =
$v
;
}
if
(
$write
and
$k
eq
'p'
) {
$v
=
$write
;
}
print
$NEW
"alias $k='$v'\n"
if
$write
;
}
elsif
( m/^([^\=\:\s]+)
(?:
(?:\s*[\=\:]\s*|\s+)
(.+)
)?
/x
) {
my
$v
= $2;
if
(
substr
(
$v
,0,1) eq
'"'
and
substr
(
$v
,-1,1) eq
'"'
) {
$v
=
substr
(
$v
,1,-1);
}
$c
->config->{$1} =
$v
;
print
$NEW
$s
if
$write
;
}
elsif
(
$write
) {
print
$NEW
$s
;
}
}
close
$CONFIG
;
if
(
$write
) {
close
$NEW
;
unlink
$CONFIG
;
rename
$filename
.
".tmp"
,
$filename
or Carp::croak
"error writing $filename: $!\n"
;
}
scalar
keys
%{
$c
->config};
}
sub
_set_alias {
my
(
$c
,
$p
) =
@_
;
my
$f
=
"$ENV{HOME}/.perlall"
;
unless
(
$p
) {
$p
=
$c
->stash->{perlall}->[0]
if
@{
$c
->stash->{perlall}} == 1;
$c
->_dot_perlall(
$f
,
$p
)
if
-f
$f
and
$p
;
}
else
{
$c
->_dot_perlall(
$f
,
"perl$p"
)
if
-f
$f
and
$p
;
}
""
}
sub
_numonly {
my
$p
=
shift
;
$p
=~ s/^.
*perl
//;
$p
=~ s/\-.+$//;
$p
=~ s/@.+$//;
$p
=~ s/thr$//;
$p
=~ s/d$//;
return
$p
;
}
sub
_short {
my
$p
=
shift
;
$p
=~ s/^.
*perl
//;
return
$p
;
}
sub
_print {
my
$level
=
shift
;
if
($^O eq
'MSWin32'
) {
print
join
(
" "
,
@_
),
"\n"
;
}
elsif
(
$level
== 0) {
print
"\033[1;32m"
,
join
(
" "
,
@_
),
"\033[0;0m\n"
;
}
elsif
(
$level
== 1) {
print
"\033[1;39m"
,
join
(
" "
,
@_
),
"\033[0;0m\n"
;
}
}
sub
_backup($) {
my
$f
=
shift
;
my
$i
= 1;
while
(-e
"$f.$i"
) {
$i
++ }
rename
$f
,
"$f.$i"
;
}
sub
__system {
my
$c
=
shift
;
unless
(
$c
->options->{dryrun}) {
if
($^O eq
'MSWin32'
and
$_
[0] =~ /^(rm|mv|
mkdir
) /) {
my
$what
=
join
" "
,
@_
;
if
(
$what
=~ /^rm -rf/) {
system
(
"$^X -MExtUtils::Command -e 'rm_rf' -- "
,
substr
(
$what
,6));
}
elsif
(
$what
=~ /^rm /) {
system
(
"$^X -MExtUtils::Command -e 'rm_f' -- "
,
substr
(
$what
,5));
}
elsif
(
$what
=~ /^mv /) {
system
(
"$^X -MExtUtils::Command -e 'mv' -- "
,
substr
(
$what
,3));
}
elsif
(
$what
=~ /^
mkdir
(-p)?(.*)/) {
system
(
"$^X -MExtUtils::Command -e 'mkpath' -- $2"
);
}
else
{
die
"unhandled $what"
;
}
}
elsif
(
$_
[0] =~ /^
chdir
|
rmdir
|
mkdir
|
unlink
|
rename
$/) {
my
$cmd
=
shift
@_
;
my
$what
=
join
"','"
,
@_
;
if
(
$cmd
=~ /^
mkdir
-p/) {
system
(
@_
);
}
else
{
eval
"$cmd('$what')"
;
}
}
else
{
my
$fh
=
$c
->stash->{log_fh};
if
($^O eq
'MSWin32'
) {
map
{ s/\'/"/g }
@_
;
}
my
(
$success
,
$error_message
,
$full_buf
,
$stdout_buf
,
$stderr_buf
) =
IPC::Cmd::run(
'command'
=> [
@_
],
(
$c
->options->{verbose}
? (
'verbose'
=> 1) : ()),
(
defined
$c
->options->{timeout}
? (
'timeout'
=>
$c
->options->{timeout} )
: ())
);
if
(
$fh
and !
$c
->options->{verbose} and
@$full_buf
) {
print
$fh
$_
for
@$full_buf
;
if
(!
$c
->options->{quiet} and
$c
->cmd =~ /^smoke|
do
|make.*|cpan.*/) {
print
$_
for
@$stdout_buf
;
}
}
if
(
@$stderr_buf
and !
$c
->options->{quiet}) {
print
STDERR
$_
for
@$stderr_buf
;
}
$success
;
}
}
}
sub
_loginit {
my
$c
=
shift
;
my
$q
=
$c
->options->{quiet};
my
$v
=
$c
->options->{verbose};
my
$dryrun
=
$c
->options->{dryrun};
my
$log
=
$c
->stash->{
log
};
if
( !
$dryrun
and
$log
) {
_backup(
$log
)
if
-e
$log
;
$c
->stash->{log_fh} = IO::File->new(
$v
?
">& $log"
:
"> $log"
);
}
}
sub
_log {
my
$c
=
shift
;
my
$level
=
shift
;
my
$q
=
$c
->options->{quiet};
my
$v
=
$c
->options->{verbose};
my
$dryrun
=
$c
->options->{dryrun};
my
$log
=
$c
->stash->{
log
};
my
$fh
=
$c
->stash->{log_fh};
local
$| = 1;
if
(
$log
) {
$c
->_loginit
unless
$fh
;
$fh
=
$c
->stash->{log_fh};
if
(!
$q
) {
if
(
$level
ne
''
) {
_print(
$level
,
@_
);
}
if
(
$fh
) {
print
$fh
join
(
" "
,
@_
),
"\n"
;
$fh
->flush;
}
elsif
(
$level
eq
''
) {
print
join
(
" "
,
@_
),
"\n"
;
}
}
elsif
(
$level
== 0) {
_print(0,
@_
);
}
}
elsif
(
$v
or
$level
== 0) {
if
(
$level
ne
''
) {
_print(
$level
,
@_
);
}
else
{
print
join
(
" "
,
@_
),
"\n"
;
}
}
}
sub
_system {
my
$c
=
shift
;
$c
->_log(
''
,
@_
)
unless
$c
->options->{quiet};
$c
->__system(
@_
);
}
sub
_system0 {
my
$c
=
shift
;
$c
->_log(0,
@_
);
$c
->__system(
@_
);
}
sub
_system1 {
my
$c
=
shift
;
$c
->_log(1,
@_
);
$c
->__system(
@_
);
}
sub
_check_lock {
my
$lock
= Cwd::getcwd().
"/perlall.lock"
;
if
(-f
$lock
) {
print
"$lock exists. Probably perlall still running.\n"
;
system
(
"pgrep"
,
"-fl"
,
"perlall"
);
exit
1;
}
open
LOCK,
">"
,
$lock
;
print
LOCK $$,
"\n"
;
close
LOCK;
$SIG
{INT} =
$SIG
{TERM} =
sub
{
my
$l
=
$lock
;
unlink
$l
if
-f
$l
;
exit
1; };
END {
my
$l
=
$lock
;
if
(-f
$l
) {
open
LOCK,
"<"
,
$l
;
my
$pid
= <LOCK>;
chomp
$pid
;
close
LOCK;
if
($$ ==
$pid
) {
unlink
$l
;
}
else
{
warn
"Other perlall process $pid still running. perlall.lock kept\n"
;
warn
`ps -l -p
$pid
`,
"\n"
;
}
}
}
}
sub
_lognew {
my
$c
=
shift
;
my
$p
=
shift
;
if
(
$p
) {
$p
=
substr
(
$p
,0,-4)
if
$p
=~ /\.exe$/;
$c
->stash->{
log
} =
$c
->stash->{logprefix} .
$p
;
}
else
{
$c
->stash->{
log
} =
substr
(
$c
->stash->{logprefix},0,-1);
}
if
(
$c
->stash->{log_fh}) {
$c
->stash->{log_fh}->
close
()
if
ref
(
$c
->stash->{log_fh}) eq
'IO::File'
;
undef
$c
->stash->{log_fh};
}
$c
->_loginit();
}
sub
_grep {
my
$c
=
shift
;
my
$cmd
=
shift
;
my
(
$inplace
,
$out
);
if
(
substr
(
$cmd
,0,3) eq
'-i '
) {
$inplace
= 1;
$cmd
=
substr
(
$cmd
,3);
}
$c
->_log(
''
,
"perl -i~ -ne'$cmd'"
,
join
(
" "
,
@_
))
if
$inplace
;
return
if
$c
->options->{dryrun};
my
$catch
=
''
;
while
(
my
$f
=
shift
@_
) {
next
unless
-f
$f
;
my
$b
=
$f
;
if
(
$inplace
) {
$b
.=
"~"
;
unlink
$b
if
-e
$b
;
rename
(
$f
,
$b
);
open
(
$out
,
">"
,
$f
);
select
$out
;
}
else
{
$out
= IO::Scalar->new(\
$catch
);
select
$out
;
}
open
(IN,
"<"
,
$b
);
LINE:
while
(<IN>) {
eval
$cmd
;
}
close
IN;
close
$out
;
}
select
(STDOUT);
$catch
;
}
sub
_patch {
my
(
$c
,
$file
) =
@_
;
$c
->_system(
"git show HEAD..blead $file | patch -N -p1"
)
and
warn
(
"patch HEAD..blead $file had some errors\n"
);
}
sub
_apply_commit {
my
(
$c
,
$commit
,
@files
) =
@_
;
$c
->_system(
"git show $commit @files | patch -N -p1"
)
and
warn
(
"cannot apply commit $commit"
.(
@files
?
" to @files"
:
""
).
"\n"
);
}
sub
_teardown {
my
$c
=
shift
;
close
$c
->stash->{log_fh}
if
$c
->stash->{log_fh};
""
}
sub
_fail {
my
$c
=
shift
;
if
(
$c
->options->{verbose}) {
warn
$c
->{output},
" at perlall line @{[(caller(0))[2]]}\n"
;
}
die
"@_\n"
;
}
sub
_glob_git {
my
$c
=
shift
;
my
$git
=
shift
;
return
qw(smoke-me/scream smoke-me/taint.t )
if
$c
->options->{dryrun};
my
$srcdir
=
$c
->config->{
'perl-git'
};
my
$cwd
= Cwd::getcwd;
chdir
"$srcdir/.git/refs/heads"
or
die
;
my
@git
=
glob
$git
;
chdir
"../remotes/origin"
or
die
;
push
@git
,
glob
$git
;
chdir
"../../tags"
or
die
;
push
@git
,
glob
$git
;
chdir
$cwd
or
die
;
return
@git
;
}
sub
build
:Help(
'build [opts] perl<version><suffix> [ branch|from ]'
)
{
my
$c
=
shift
;
my
$cperl
;
if
(@{
$c
->argv}) {
my
@build_opts
=
(
[
"as=s"
,
"install perl under given name"
],
[
"D=s@"
,
"./configure option"
],
[
"A=s@"
,
"./configure option"
],
[
"U=s@"
,
"./configure option"
],
[
"j=n"
,
"parallel make (>5.10)"
],
[
"link"
,
"make symlinks (blead only) from git"
],
[
"notest|n"
,
"skip the test suite on build and makeinstall"
],
[
"force|f"
,
"force install"
],
[
'install'
,
'skip make, only do install'
],
[
"allpatches"
,
"apply also Asan and Compiler patches"
],
[
"patches=s@"
,
" apply Compiler or Asan patches (Devel::PatchPerl::Plugin)"
],
);
$c
->addopts(
map
{
$_
->[0]}
@build_opts
);
}
my
@args
= @{
$c
->argv};
my
$p
=
$args
[0];
if
(
$p
=~ /^(c?perl)?5\./ ) {
shift
@args
;
}
elsif
(
$p
=~ /^blead/ ) {
my
$srcdir
=
$c
->config->{
'perl-git'
} or
$c
->_fail(
"blead needs perl-git"
);
my
$v
= `$^X -ane
'print \$F[2] if /PERL_API_VERSION/'
$srcdir
/patchlevel.h`;
my
$sv
= `$^X -ane
'print \$F[2] if /PERL_API_SUBVERSION/'
$srcdir
/patchlevel.h`;
$p
=
"5.$v.$sv"
.
substr
(
$p
,5);
if
(
@args
> 1) {
shift
@args
;
}
else
{
$args
[0] =
'blead'
;
}
}
else
{
$c
->output(
"perlall build missing perlversion argument\n"
);
$c
->execute(
'help'
) and
return
undef
;
}
$cperl
= 1
if
$p
=~ /^cperl/;
$p
=~ s/^c?perl//;
$p
=~ s/^-//;
if
(
$p
=~ /[\*\?\[]/ or
$p
!~ /^5\.\d/) {
$c
->output(
"perlall build invalid perlversion argument $p\n"
);
$c
->execute(
'help'
) and
return
undef
;
}
my
$cwd
= Cwd::getcwd();
END {
chdir
$cwd
if
$cwd
}
my
$dryrun
=
$c
->options->{dryrun};
my
$root
=
$c
->config->{PERLALL_BUILDROOT};
my
$prefix
=
$c
->config->{PERLALL_PREFIX};
unless
(
$root
) {
$c
->_fail(
"Empty PERLALL_BUILDROOT in .perlall"
);
}
if
(!-d
$root
and !
$dryrun
) {
$c
->_log( 1,
"mkdir $root # PERLALL_BUILDROOT"
);
$c
->_system1(
"mkdir"
,
$root
)
and
$c
->_fail(
"Cannot create PERLALL_BUILDROOT $root"
);
}
my
$from
=
shift
@args
;
my
$ps
= _numonly(
$p
);
my
(
$suffix
) =
$p
=~ /5\.\d\d?\.\d\d?(.+)$/;
my
$gitsuffix
;
unless
(
$from
) {
if
(
$cperl
and
$ps
=~ /^5\./ and -d
$c
->config->{
'cdcperl'
}) {
$from
=
"cperl-$ps"
;
}
elsif
(
$ps
=~ /^5\./ and -d
$c
->config->{
'perl-git'
}) {
$from
=
$c
->_older(
$ps
,
"5.11.0"
) ?
"perl-$ps"
:
"v$ps"
;
}
elsif
(
$c
->options->{install}) {
;
}
else
{
$c
->_log(1,
"downloading perl-$ps via CPAN::Perl::Releases"
);
_auto_use(
"CPAN::Perl::Releases"
);
my
$urls
= CPAN::Perl::Releases::perl_tarballs(
$ps
);
my
$url
= (
values
%$urls
)[0];
require
CPAN; CPAN->
import
;
warn
"CPAN::Shell->get(qw($url))\n"
;
CPAN::Shell->get(
$url
);
}
}
if
(
$c
->options->{as}) {
my
$p_as
=
$c
->options->{as};
$p_as
=~ s/^c?perl//;
$p_as
=~ s/^-//;
my
$suffix_as
=
$p_as
=~ /5\.\d\d?\.\d\d?(.+)$/;
if
(
$suffix_as
) {
$gitsuffix
=
$suffix_as
;
$ps
= _numonly(
$p_as
)
unless
$ps
;
$c
->debug(
"explicit --as suffix $suffix_as"
);
}
else
{
warn
"missing version for --as suffix $suffix_as"
;
}
}
else
{
my
(
$suffix_as
) =
$suffix
=~
/^d?(?:-nt|thr)?(?:-clang|-tsan|-asan|-msan|-mad|-cow)?(?:@.+)?(.*)$/;
if
(
$suffix_as
) {
$gitsuffix
=
$suffix_as
;
$c
->debug(
"implicit --as suffix $gitsuffix"
);
}
}
warn
"--link ignored. Only valid with blead.\n"
if
$c
->options->{
link
} and
$from
ne
'blead'
;
$c
->_system(
"chdir"
,
$root
);
if
(!
$gitsuffix
and
$from
and
$from
!~ /^(c?perl-|v)5\./) {
$gitsuffix
=
$from
if
!
$gitsuffix
and
$from
!~ /^(perl-|v)5\./;
if
(
$gitsuffix
=~ /^[a-f0-9]{5,24}$/) {
$gitsuffix
=
"@"
.
substr
(
$gitsuffix
,0,6);
$p
.=
$gitsuffix
unless
$p
=~ /@/;
}
else
{
if
(
$gitsuffix
=~ /\*/) {
my
$result
=
''
;
my
@git
=
$c
->_glob_git(
$gitsuffix
);
_print(0,
"perlall build $p $gitsuffix => "
,
@git
);
for
my
$git
(
@git
) {
my
$pg
=
$p
;
my
$s
=
$git
;
$s
=~ s/^smoke-me\///;
$s
=~ s/\W//g;
$pg
=
$p
.
"@"
.
substr
(
$s
,0,12);
$result
.=
$c
->_build(
$pg
,
$git
,
$ps
,
'@'
.
$git
,
$root
,
$prefix
,
$cwd
);
}
return
$result
;
}
my
$srcdir
=
$cperl
?
$c
->config->{
'cdcperl'
} :
$c
->config->{
'perl-git'
};
if
(
$gitsuffix
=~ /^blead/ and !
$dryrun
and -d
"$srcdir/.git"
) {
$gitsuffix
=
substr
(`GIT_DIR=
$srcdir
/.git git rev-parse
$gitsuffix
`,0,8);
}
unless
(
$p
=~ /@/) {
my
$git
=
$gitsuffix
;
$git
=~ s/^smoke-me\///;
$git
=~ s/\W//g;
$git
=
"@"
.
substr
(
$git
,0,12);
$p
.=
$git
;
}
$gitsuffix
=
"@"
.
$gitsuffix
;
}
}
return
$c
->_build(
$p
,
$from
,
$ps
,
$gitsuffix
,
$root
,
$prefix
,
$cwd
);
}
sub
_build {
my
(
$c
,
$p
,
$from
,
$ps
,
$gitsuffix
,
$root
,
$prefix
,
$cwd
) =
@_
;
$c
->debug(
"c, \$p=$p, \$from=$from, \$ps=$ps, \$gitsuffix=$gitsuffix,"
.
" \$root=$root, \$prefix=$prefix, \$cwd=$cwd"
);
my
$make
=
$Config
{make};
my
$sed
=
$Config
{sed};
$sed
=
"sed"
unless
$sed
;
my
$cp
=
$Config
{cp};
$cp
=
"cp"
unless
$cp
;
my
$mv
=
$Config
{mv};
$mv
=
"mv"
unless
$mv
;
my
$rm
=
$Config
{rm};
$rm
=
"rm"
unless
$rm
;
my
$sudo
=
$c
->config->{sudo};
$sudo
=
""
if
$root
=~ m!^/home!;
$sudo
=
""
unless
$<;
my
@j
= (
"-j"
.
$c
->options->{j})
if
$c
->options->{j} and !
$c
->_older(
$ps
,
"5.10.0"
);
my
(
$testerr
,
$archname
);
my
$is_cperl
=
$from
=~ /^cperl/;
my
$dryrun
=
$c
->options->{dryrun};
my
$srcdir
=
$is_cperl
?
$c
->config->{
'cdcperl'
} :
$c
->config->{
'perl-git'
};
my
(
$suffix
) =
$p
=~ /5\.\d\d?\.\d\d?(.+)$/;
my
$debug
=
substr
(
$suffix
,0,1) eq
'd'
;
my
$multi
=
$suffix
=~ /^d?-m[^a-z]?/;
my
$ithreads
=
$suffix
!~ /^d?-nt[^a-z]?/;
my
(
$archsuffix
) =
$suffix
=~ /d?(?:-nt|-m[^a-z]?|thr)(.+)$/;
my
(
$asan
,
$cc
);
if
(
$suffix
=~ /-mad/) {
push
@{
$c
->options->{D}},
"mad=y"
;
}
if
(
$suffix
=~ /-cow/) {
push
@{
$c
->options->{A}},
"ccflags=-DPERL_NEW_COPY_ON_WRITE"
;
}
if
(
$suffix
=~ /-(clang|asan|tsan|msan|ubsan|isan|dflow|sstack|cps|cpi)/) {
$cc
=
'clang'
;
unless
(
grep
/cc=/, @{
$c
->options->{D}}) {
push
@{
$c
->options->{D}},
"cc=clang"
;
}
else
{
(
$cc
) =
map
/cc=(.*)$/, @{
$c
->options->{D}};
}
push
@{
$c
->options->{D}},
"optimize='-fno-omit-frame-pointer -gline-tables-only'"
;
if
(
$suffix
=~ /-asan/) {
$asan
=
"-fsanitize=address"
;
push
@{
$c
->options->{A}},
"ccflags=$asan"
;
}
if
(
$suffix
=~ /-(cps|cpi)/) {
my
$san
= $1;
push
@{
$c
->options->{D}},
"cc=clang-cps"
,
"ld=clang-cps"
;
push
@{
$c
->options->{A}},
"ccflags='-f$san'"
,
"ldflags='-f$san'"
,
"lddlflags='-f$san'"
;
}
if
(
$suffix
=~ /-(tsan|ubsan|msan|isan|dflow)/) {
my
%sanmap
= (
tsan
=>
'thread'
,
ubsan
=>
'undefined'
,
msan
=>
'memory'
,
isan
=>
'integer'
,
dflow
=>
'dataflow'
,
sstack
=>
'safestack'
,
);
my
$san
=
$sanmap
{$1};
push
@{
$c
->options->{A}},
"ccflags='-fsanitize=$san -fPIE'"
,
"ldflags='-fsanitize=$san -fpie'"
,
"lddlflags='-shared -fsanitize=$san -fpie'"
;
}
}
$ithreads
=
undef
if
$multi
;
my
$bindir
=
$c
->config->{PERLALL_BINDIR};
if
(
$c
->options->{install}) {
$c
->stash->{logprefix} =~ s/^
log
.build-/
log
.build-install-/;
}
$c
->stash->{
log
} =
"$root/"
.
$c
->stash->{logprefix} .
$p
;
if
(
$c
->stash->{log_fh}) {
close
$c
->stash->{log_fh};
undef
$c
->stash->{log_fh};
}
$c
->_log(0,
"perlall"
,_opts(
$c
->options),
"build"
,
$p
,
$from
);
my
$builddir
=
"build-"
.
$p
;
if
(
$c
->options->{install}) {
$c
->_system1(
"chdir"
,
$root
.
'/'
.
$builddir
);
$c
->_check_lock();
goto
INSTALL;
}
if
(-f
$from
or
$from
=~ /^https?:|ftp:|rsync:/) {
warn
"XXX build from file very very unstable.\n"
.
"No idea how to know the resulting srcdir yet"
;
if
(!-f
$from
) {
$c
->_system1(
"wget"
,
"-O"
,
"perl-$ps.tgz"
,
$from
)
and
$c
->_fail(
"downloading $from failed"
);
$from
=
"perl-$ps.tgz"
;
}
my
@tarx
= (($^O eq
'solaris'
?
'gtar'
:
'tar'
),
(
$from
=~ m/\.bz2$/ ?
'xjf'
:
'xzf'
));
$c
->_system1(
@tarx
,
$from
) and _fail(
"extracting the tarball $from failed"
);
$srcdir
=
$root
.
"/perl-$ps"
;
if
(! -d
$builddir
) {
$c
->_system(
"mkdir"
,
$builddir
)
and
$c
->_fail(
"Cannot create $builddir."
.
" Check your PERLALL_BUILDROOT in ~/.perlall"
);
}
$c
->_system1(
"chdir"
,
$root
.
'/'
.
$builddir
);
$c
->_check_lock();
}
else
{
$c
->_fail(
"perl-git $srcdir missing"
)
if
!-d
$srcdir
and !
$dryrun
;
my
@cmd
= (
"mkdir"
,
$builddir
);
unshift
@cmd
,
$sudo
if
$sudo
and !-w
$root
;
$c
->_log(1,
"mkdir $root/$builddir # PERLALL_BUILDROOT"
)
unless
-d
$builddir
;
$c
->_system1(
@cmd
)
unless
-d
$builddir
;
$c
->_fail(
"invalid builddir $builddir"
)
if
!-d
$builddir
and !
$dryrun
;
$c
->_system(
$sudo
,
"chown"
, $<,
$builddir
)
if
$sudo
eq
$cmd
[0];
if
(
$from
eq
'blead'
and
$c
->options->{
link
} ) {
$c
->debug(
"working symlinked to perl-git tree \@$gitsuffix"
)
if
$c
->options->{
link
};
$c
->_system1(
"chdir"
,
$root
.
'/'
.
$builddir
);
$c
->_fail(
"not existing builddir $builddir"
)
if
basename(Cwd::getcwd()) ne
$builddir
and !
$dryrun
;
$c
->_check_lock();
$c
->_system1(
"rm -rf * .config"
)
if
-f
'Configure'
and !-l
"Configure"
;
}
else
{
$c
->debug(
"copy git tree for $from"
);
@cmd
= (
$cp
,
"-rf"
,
"$srcdir/.git"
,
"$builddir/"
);
if
($^O eq
'MSWin32'
) {
$c
->_system1(
"rm -rf \"$builddir\\.git\""
)
if
-d
"$builddir/.git"
;
@cmd
= (
"xcopy"
,
"/S/I/H/Y"
.(
$c
->options->{verbose}?
""
:
"/Q"
),
"\"$srcdir/.git\""
,
"\"$builddir\\.git\""
);
}
$c
->_system1(
@cmd
);
$srcdir
=
"."
;
$c
->_system1(
"chdir"
,
$builddir
);
$c
->_fail(
"not existing builddir $builddir"
)
if
basename(Cwd::getcwd()) ne
$builddir
and !
$dryrun
;
$c
->_check_lock();
$c
->_system1(
"git"
,
"checkout"
,
"-f"
,
$from
);
$c
->_fail(
"git checkout -f $from"
)
if
!-f
"Configure"
and !
$dryrun
;
$c
->_system1(
"git"
,
"reset"
,
"--hard"
);
$c
->_system1(
"git"
,
"clean"
,
"-dxf"
);
}
}
if
(
$srcdir
eq
"."
or
$srcdir
eq
$root
.
"/perl-$ps"
) {
$c
->_log(
''
,
"Devel::PatchPerl::patch_source($ps)"
);
if
(
$asan
or
$c
->options->{allpatches} or
grep
/^Asan$/, @{
$c
->options->{patches}}) {
$c
->_log(
''
,
"Devel::PatchPerl::patch_source($ps) Asan"
);
local
$ENV
{PERL5_PATCHPERL_PLUGIN} =
'Devel::PatchPerl::Plugin::Asan'
;
Devel::PatchPerl::patch_source(
$ps
)
unless
$dryrun
;
}
elsif
(
$c
->options->{allpatches} or
grep
/^Compiler$/, @{
$c
->options->{patches}}) {
local
$ENV
{PERL5_PATCHPERL_PLUGIN} =
'Devel::PatchPerl::Plugin::Compiler'
;
$c
->_log(
''
,
"Devel::PatchPerl::patch_source($ps) Compiler"
);
Devel::PatchPerl::patch_source(
$ps
)
unless
$dryrun
;
}
else
{
Devel::PatchPerl::patch_source(
$ps
)
unless
$dryrun
;
}
if
(
$ps
=~ /^5\.19\.[3456789]/ and
$debug
) {
local
$ENV
{PERL5_PATCHPERL_PLUGIN} =
'Devel::PatchPerl::Plugin::General'
;
$c
->_log(
''
,
"Devel::PatchPerl::patch_source($ps) General"
);
Devel::PatchPerl::patch_source(
$ps
)
unless
$dryrun
;
}
if
(
$ps
=~ /^5\.6\.2/) {
$c
->_log(
''
,
"patch to use 5.8.0 lib/File/Find.pm"
);
$c
->_system(
"git diff HEAD..perl-5.8.0 lib/File/Find.pm | patch -N -p1"
)
and
warn
(
"patch HEAD..perl-5.8.0 lib/File/Find.pm had some errors\n"
);
}
}
elsif
(!
$dryrun
) {
warn
"Warning: Building -Dmksymlink with no Devel::PatchPerl patches applied.\n"
.
"Use --no-link if this fails.\n"
;
}
if
( !
$gitsuffix
and -d
".git"
and !
$c
->options->{debug}) {
$c
->_system1(
$rm
,
"-rf"
,
".git"
);
}
$c
->_system(
$rm
,
"config.h"
)
if
-f
"config.h"
;
$c
->_system(
$rm
,
"Policy.sh"
)
if
-f
"Policy.sh"
;
$c
->_system(
$rm
,
"-rf"
,
"UU"
)
if
-d
"UU"
;
$c
->_system(
$rm
,
"-rf"
,
".config"
)
if
-d
".config"
;
my
@conf
= (
"sh"
,
"$srcdir/Configure"
,
"-de"
,
"-Dusedevel"
,
"-Uversiononly"
,
"-Dinstallman1dir=none"
,
"-Dinstallman3dir=none"
,
"-Dinstallsiteman1dir=none"
,
"-Dinstallsiteman3dir=none"
);
my
(
$libperl
);
if
(
$c
->config->{usethrsuffix} and !
$multi
) {
$ithreads
=
$suffix
=~ /^d?thr/;
}
push
@conf
,
"-Dmksymlinks"
if
$srcdir
ne
"."
;
push
@conf
,
"-DEBUGGING"
if
$debug
;
push
@conf
,
"-Doptimize='-g3'"
if
$debug
and
$Config
{gccversion} and !
grep
(/^optimize=/, @{
$c
->options->{D}});
push
@conf
,
"-Dusemultiplicity"
if
$multi
;
if
($^O eq
'cygwin'
) {
push
@conf
, (
$ithreads
?
"-D"
:
"-U"
) .
"usethreads"
;
}
else
{
push
@conf
, (
$ithreads
?
"-D"
:
"-U"
) .
"useithreads"
;
}
push
@conf
,
"-Uuseshrplib"
if
$^O eq
'darwin'
and
$debug
;
push
@conf
,
"-D'"
.
$_
.
"'"
for
@{
$c
->options->{D}};
push
@conf
,
"-A'"
.
$_
.
"'"
for
@{
$c
->options->{A}};
push
@conf
,
"-U'"
.
$_
.
"'"
for
@{
$c
->options->{U}};
push
@conf
,
"-Dprefix='$prefix'"
if
$prefix
ne
'/usr/local'
;
if
($^O =~ /cygwin|msys/ and
$suffix
) {
if
($^O eq
'cygwin'
) {
$libperl
=
$ps
;
$libperl
=~ s/\./_/g;
$libperl
=
'cygperl'
.
$libperl
.
$suffix
.
'.dll'
;
push
@conf
,
"-Dlibperl=$libperl"
;
}
else
{
$libperl
=
$ps
;
$libperl
=~ s/\.//g;
$libperl
=
'perl'
.
$libperl
.
$suffix
.
'.dll'
;
push
@conf
,
"-Dlibperl=$libperl"
;
}
}
if
(
grep
/-[DA]'ccflags=.*-fsanitize=address/,
@conf
) {
my
$f
=
'ldflags'
;
if
(!(
grep
/-[DA]'
$f
=.*-fsanitize=address/,
@conf
)) {
push
@conf
,
"-A'$f=$asan"
. ($^O eq 'darwin
' ? "\\ -Wl,-no_pie'
" :
"'"
);
}
$f
=
'lddlflags'
;
if
(!(
grep
/-[DA]'
$f
=.*-fsanitize=address/,
@conf
)
and !(
grep
/-U'?useshrplib/,
@conf
)) {
push
@conf
,
($^O eq
'darwin'
?
"-A'$f=-bundle\\ $asan\\ -Wl,-no_pie'"
:
"-A'$f=-shared\\ $asan'"
),
"-Duseshrplib"
;
}
}
$c
->_system(
$rm
,
"config.sh"
)
if
-f
"config.sh"
;
$c
->debug(
"config_args: "
.
join
(
" "
,
@conf
));
for
my
$tryperl
(
"$bindir/perl"
,
"/usr/local/bin/perl"
,
"/usr/bin/perl"
) {
if
(-e
$tryperl
) {
my
$tryargs
= `
$tryperl
-V:config_args`;
$c
->debug(
"old args: $tryargs"
);
for
my
$f
(
qw(cc ld ccflags ldflags libpth incpth pager
cf_email perladmin)
)
{
next
if
grep
/^
$f
[= ]/, @{
$c
->options->{D}}
or
grep
/^
$f
[= ]/, @{
$c
->options->{A}}
or
grep
/^
$f
[= ]/, @{
$c
->options->{U}};
my
(
$d
,
$v
) =
$tryargs
=~ m/-([AUD])
$f
=(.+?) (?:-[ADU]|;)/;
if
(
$f
=~ /^
use
/ and !
$v
) {
my
(
$u
) =
$tryargs
=~ /-([DU])
$f
/;
$c
->debug(
"-$u$f"
)
if
$u
;
push
@conf
,
"-$u$f"
if
$u
;
}
elsif
(
$v
and
$d
) {
$v
=~ s/([^\\]) /$1\\ /g;
if
(
$d
eq
'A'
) {
for
my
$v
(
$tryargs
=~ m/-A
$f
=(.+?) /g) {
$c
->debug(
"-$d$f=$v"
)
if
$v
;
$v
=~ s/([^\\]) /$1\\ /g;
push
@conf
,
"-$d$f='$v'"
;
}
}
else
{
next
if
$^O =~ /bsd/ and
$f
eq
"ccflags"
and
$v
=~ /APPLLIB_EXP.
*BSDPAN
/;
if
(
grep
/^
$f
[= ](.*)/, @{
$c
->options->{D}}) {
$d
=
'D'
;
$v
= $1;
$c
->debug(
"-A$f"
);
$v
=~ s/([^\\]) /$1\ /g;
push
@conf
,
"-D$f='$v'"
;
}
elsif
(
grep
/^
$f
[= ]/, @{
$c
->options->{U}}) {
$d
=
'U'
;
$v
=
''
;
$c
->debug(
"-U$f"
);
}
else
{
$c
->debug(
"-$d$f=$v"
);
$v
=~ s/([^\\]) /$1\ /g;
push
@conf
,
"-$d$f='$v'"
;
}
}
}
}
$c
->debug(
"merged config_args: "
.
join
(
" "
,
@conf
));
last
;
}
}
if
(
$ps
=~ /^5\.6\.2/ and $^O =~ /darwin|bsd|dragon/) {
push
@conf
,
"-Dd_Gconvert=sprintf"
;
}
if
($^O eq
'darwin'
) {
my
$conf
=
join
(
" "
,
@conf
);
push
@conf
,
"-Aldflags=-flat_namespace"
if
$conf
=~ /ccflags=
'?-m64/ or $conf =~ /ccflags='
?-m32/;
push
@conf
,
"-Dld=$cc"
if
$cc
=~ /clang/;
if
(
$c
->_older(
$p
,
'5.6.2'
)) {
}
}
if
($^O eq
'msys'
) {
push
@conf
,
"-Dlibc=/usr/lib.libmsys-1.0.dll.a"
,
"-Dusenm=no"
;
}
if
(
$cc
=~ /clang/) {
push
@conf
,
"-Accflags=-Wno-unused-value"
;
}
if
($^O ne
'MSWin32'
) {
$c
->_system1(
@conf
);
$c
->_fail(
"Configure failed"
)
unless
-f
'config.sh'
or
$dryrun
;
}
else
{
my
(
$w64
,
$config
);
my
$aperl
=
$make
eq
'nmake'
;
$c
->_system1(
"chdir"
,
"win32"
);
my
$makefile
=
$aperl
?
'Makefile'
:
'makefile.mk'
;
if
(
$ENV
{WIN64}) {
$w64
++;
warn
"WIN64 not yet tested"
;
}
if
(
$w64
) {
$config
=
$aperl
?
'config.vc64'
:
'config.gc64'
; }
else
{
$config
=
$aperl
?
'config.vc'
:
'config.gc'
;}
$c
->_log(1,
"win32 configure $config $make"
);
$c
->_system1(
$cp
,
$config
,
'config.h'
);
$dryrun
= 1;
}
$c
->_log(1,
"post-configure fixes"
);
$archname
=
$dryrun
?
"fake-arch"
:
$c
->_grep(
"/^archname='(.+?)'\$/ and print \$1"
,
"config.sh"
);
my
$new
=
$archname
;
for
my
$d
(@{
$c
->options->{D}}) {
if
(
$d
=~ /^archname/) {
$new
=
$d
;
$new
=~ s/^archname=//;
$new
=~ s/'//g;
}
}
if
((
$new
ne
$archname
) or
$archsuffix
or
$debug
) {
if
(
$new
eq
$archname
) {
if
(
$archname
=~ /-thread-multi/ and !
$c
->_older(
$ps
,
"5.10.0"
)) {
$new
=~ s/-thread-multi/-thread/;
}
$new
.=
"-debug"
if
$debug
and
$archname
!~ /-debug/;
$new
.=
$archsuffix
if
$archsuffix
and
$archname
!~ /
$archsuffix
$/;
if
(!
$ithreads
and
$new
=~ /-thread/) {
$new
=~ s/-thread//;
}
elsif
(
$ithreads
and
$new
!~ /-thread/) {
$new
.=
"-thread"
;
}
}
$c
->debug(
"post-configure archname fixes: $archname => $new"
);
$c
->_fail(
"archname not detected in config.sh"
)
unless
$archname
;
if
(
$archname
and
$archname
ne
$new
) {
$new
=~ s/([\$\%\@])/\\$1/g;
$c
->_grep(
"-i s|(\\d)/$archname'|\\1/$new'|;"
.
" s|(\\d)/$archname\"|\\1/$new\"|;"
.
" s|/$archname/CORE|/$new/CORE|;"
.
" s|define ARCHNAME \"$archname\"|define ARCHNAME \"$new\"|;"
.
" s|archname=$archname,|archname=$new,|;"
.
" s|archname='$archname'|archname='$new'|; print"
,
qw(config.h config.sh Policy.sh myconfig)
);
}
}
if
(!
$dryrun
and
$c
->_older(
$p
,
'5.14'
)) {
if
(
$c
->_grep(
'm|inc_version_list.+(\d\.\d\d?\.\d\d?)/'
.
$archname
.
' | and print $1'
,
"config.sh"
)) {
$c
->debug(
"post-configure remove archlibs from inc_version_list"
);
$c
->_grep(
'-i s|(\d\.\d\d?\.\d\d?)/'
.
$archname
.
' ||;'
.
' s|"(\d\.\d\d?\.\d\d?)/'
.
$archname
.
'",||;'
.
" print"
,
qw(config.h config.sh)
);
}
}
if
(
$archname
and
$archname
ne
$new
) {
$archname
=
$new
;
}
if
($^O =~ /cygwin|msys/) {
$c
->debug(
"post-configure perl.dll fixes"
);
my
$dll
=
$dryrun
?
"fake.dll"
:
$c
->_grep(
"/^libperl='(.+?)'\$/ and print \$1"
,
"config.sh"
);
if
(
$libperl
eq
$dll
) {
$c
->_log(
''
,
"configure did keep our libperl, good"
);
}
elsif
(
$libperl
and
$dll
) {
$libperl
=~ s/([\.\$\%\@])/\\$1/g;
$c
->_grep(
"-i s,$dll,$libperl,; print"
,
qw(config.sh config.h Makefile GNUmakefile myconfig)
);
if
($^O eq
'cygwin'
) {
$c
->_grep(
"-i s,libperl='libperl\.a',libperl='$libperl',; print"
,
qw(config.sh)
);
$c
->_grep(
"-i s,libperl=libperl\.a,libperl=$libperl,; print"
,
qw(myconfig)
);
}
}
if
($^O eq
'cygwin'
and !
$dryrun
) {
my
$cygmk
=
'cygwin/Makefile.SHs'
;
my
$dll
=
substr
(
$libperl
,0,-4);
if
(
$c
->_older(
$p
,
'5.8.9'
)) {
if
(-e
$cygmk
and
$c
->_grep(
"/^linklibperl=(-l)/ and print \$1"
,
$cygmk
)) {
$c
->debug(
"post-configure LLIBPERL llibperl fixes"
);
$c
->_grep(
"-i s/^LLIBPERL= \$linklibperl/DLLNAME= $dll/; print"
,
$cygmk
);
$c
->_grep(
'-i s/^-o $(LIBPERL)$(DLSUFFIX)/-o $(DLLNAME)$(DLSUFFIX)/; print'
,
$cygmk
);
$c
->_grep(
'-i s/^$(LIBPERL).dll$(LIB_EXT): $& perl$(OBJ_EXT) $(cwobj) ld2/'
.
'libperl.dll$(LIB_EXT): $& perl$(OBJ_EXT) $(cwobj)/; print;'
,
$cygmk
);
$c
->_grep(
'-i s/$(LDLIBPTH) ld2 $(SHRPLDFLAGS) -o $(LIBPERL)$(DLSUFFIX)/'
.
'$(LDLIBPTH) $(CC) $(SHRPLDFLAGS) -o $(DLLNAME)$(DLSUFFIX) -Wl,--out-implib=$@/; print'
,
$cygmk
);
}
}
if
(
my
$dllname
=
$c
->_grep(
"/^DLLNAME= (\$dllname)\$/ and print \$1"
,
$cygmk
)) {
$c
->debug(
"post-configure DLLNAME $dllname fixes"
);
if
(
$dll
ne
$dllname
) {
$c
->_grep(
"-i s/^DLLNAME= \$dllname/DLLNAME= $dll/; print"
,
$cygmk
);
}
$c
->_grep(
'-i s/^-o $(LIBPERL)$(DLSUFFIX)/-o $(DLLNAME)$(DLSUFFIX)/; print'
,
$cygmk
);
}
$c
->_grep(
'-i s/^-o $(LIBPERL)$(DLSUFFIX)/-o $(DLLNAME)$(DLSUFFIX)/; print'
,
$cygmk
);
}
}
if
($^O eq
'darwin'
) {
$c
->debug(
"post-configure darwin ld fixes"
);
my
$ld
=
$dryrun
?
"env MACOSX_DEPLOYMENT_TARGET=10.3 cc"
:
$c
->_grep(
"/^ld='(.+?)'/ and print \$1"
,
"config.sh"
);
my
$cc
=
$dryrun
?
"cc"
:
$c
->_grep(
"/^cc='(.+?)'/ and print \$1"
,
"config.sh"
);
if
(
$ld
ne
$cc
) {
$c
->_grep(
"-i s,^ld='$ld',ld='$cc',; print"
,
"config.sh"
);
}
}
$c
->debug(
"post-configure startperl fixes"
);
my
$qp
=
$p
;
$qp
=~ s/([\$\%\@])/\\$1/g;
$c
->_grep(
"-i s,bin/perl,bin/perl$qp,; print"
,
qw(config.h config.sh)
);
my
$makefile
= -f
"GNUmakefile"
?
"GNUmakefile"
:
"makefile"
;
if
(!
$dryrun
and `
grep
'<command-line>'
$makefile
`) {
$c
->debug(
"post-configure old-perl Makefile <command-line> fixes"
);
$c
->_grep(
"-i print unless /<command-line>/"
,
$makefile
,
"x2p/$makefile"
);
}
if
($^O eq
'MSWin32'
) {
$dryrun
=
$c
->options->{dryrun};
$c
->_log(1,
"win32 $make"
);
$c
->_system1(
$make
);
$c
->_system1(
"chdir"
,
".."
);
}
else
{
$c
->_system1(
$make
,
@j
);
}
$c
->debug(
"post-make versiononly"
);
if
(!
grep
/^-Uversiononly/, @{
$c
->options->{U}}) {
$c
->_grep(
"-i s/versiononly='undef'/versiononly='define'/; print"
,
"config.sh"
,
'lib/Config_heavy.pl'
);
}
if
(
$c
->cmd eq
'smoke'
) {
return
$c
->execute(
'_smoke'
,
$p
,
$from
,
@j
);
}
unless
(
$c
->options->{notest}) {
local
$ENV
{TEST_JOBS} = 4;
if
(
$dryrun
) {
$c
->_system1(
join
(
" "
,
$make
,
@j
,
"test_harness"
));
}
else
{
if
($^O eq
'MSWin32'
) {
$c
->_system1(
join
(
" "
,
$make
,
@j
,
"test_harness"
,
"> log.test"
));
}
else
{
$c
->_system1(
join
(
" "
,
$make
,
@j
,
"test_harness"
,
"2>&1 |tee log.test"
));
}
system
(
"tail -30 log.test"
)
unless
$dryrun
or
$c
->options->{quiet};
$testerr
= `
grep
"All tests successful."
log
.test` ?
undef
: 1;
}
}
INSTALL:
if
($^O eq
'cygwin'
) {
my
$patch
=
<<'EOP'; # ignored
--- installperl.orig 2012-02-03 16:10:51.000000000 -0600
+++ installperl 2012-02-03 19:53:29.614891000 -0600
@@ -263,9 +263,11 @@
if ($Is_Cygwin) {
$perldll = $libperl;
- my $v_e_r_s = substr($ver,0,-2); $v_e_r_s =~ tr/./_/;
- $perldll =~ s/(\..*)?$/$v_e_r_s.$dlext/;
- $perldll =~ s/^lib/cyg/;
+ if (substr($perldll,-4) ne ".dll") {
+ my $v_e_r_s = substr($ver,0,-2); $v_e_r_s =~ tr/./_/;
+ $perldll =~ s/(\..*)?$/$v_e_r_s.$dlext/;
+ $perldll =~ s/^lib/cyg/;
+ }
} else {
$perldll = 'perl58.' . $dlext;
}
EOP
$c
->debug(
"patch installperl for perldll"
);
$c
->_grep(
'-i s{\$perldll =~ s/^lib/cyg/}{\$perldll = \$libperl}; print'
,
'installperl'
);
}
if
(!
$archname
) {
$archname
=
$dryrun
?
"fake-arch"
:
$c
->_grep(
"/^archname='(.+?)'\$/ and print \$1"
,
"config.sh"
);
}
if
(!
$testerr
or
$c
->options->{force}) {
$c
->_system1(
"rm"
,
"-rf"
,
"$root/inst-$p"
);
if
(
$c
->_older(
$p
,
'5.8.1'
)) {
warn
(
"TODO perl <= 5.8.0 needs to patch installperl: DESTDIR, versiononly w/ lib"
);
}
if
($^O eq
'darwin'
and
$c
->_older(
$p
,
'5.6.2'
)) {
$c
->_system1(
'mv'
,
'INSTALL'
,
'INSTALL.txt'
);
}
if
($^O eq
'cygwin'
and
$c
->_older(
$p
,
'5.9.0'
)) {
$c
->_system1(
"mkdir -p $prefix/lib/perl5/$ps/$archname"
);
}
my
@c
= (
$make
,
@j
,
"install"
,
"DESTDIR=$root/inst-$p"
);
unshift
@c
,
$sudo
if
$sudo
and (!-w
"$root"
or
$c
->_older(
$p
,
'5.8.1'
));
$c
->_system1(
@c
);
}
my
$static_ext
;
if
(-d
"$root/inst-$p"
and
$static_ext
=
$c
->_grep(
"m|static_ext='(.+?)'| and print \$1"
,
"config.sh"
)) {
$c
->debug(
"post-make install static extensions $static_ext"
)
if
$static_ext
;
for
my
$ext
(
split
(/ /,
$static_ext
)) {
my
$base
= basename(
$ext
);
my
$dir
=
"$root/inst-$p$prefix/lib/perl5/$ps/$archname/auto/$ext"
;
$c
->_system1(
"mkdir -p $dir"
)
unless
-d
$dir
;
$c
->_system1(
$cp
,
"lib/auto/$ext/$base.a"
,
"$dir/"
)
if
-e
"lib/auto/$ext/$base.a"
;
}
}
if
(
$c
->_older(
$p
,
'5.8.1'
)) {
my
@c
= (
$mv
,
"$bindir/perl$ps"
,
"$bindir/perl$p"
);
unshift
@c
,
$sudo
if
$sudo
and !-w
"$bindir/perl$p"
;
$c
->_system1(
@c
);
}
elsif
(-f
"$root/inst-$p$prefix/bin/perl$ps"
) {
my
@c
= (
$cp
,
"$root/inst-$p$prefix/bin/perl$ps"
,
"$bindir/perl$p"
);
unshift
@c
,
$sudo
if
$sudo
and !-w
"$bindir/perl$p"
;
$c
->_system1(
@c
);
if
($^O =~ /^MSWin32|cygwin/) {
$c
->_system1(
"$cp $root/inst-$p$prefix/bin/*.dll $bindir/"
);
}
if
(
$from
eq
'blead'
and $^O ne
'MSWin32'
) {
my
$s
=
$p
;
$s
=~ s/\@.*//;
my
@c
= (
'ln'
,
'-sf'
,
"$bindir/perl$p"
,
"$bindir/perl$s\@blead"
);
unshift
@c
,
$sudo
if
$sudo
and !-w
"$bindir/perl$p"
;
$c
->_system(
@c
);
$c
->_system(
'mv'
,
"$root/inst-$p$prefix/bin/perl$ps"
,
"$root/inst-$p$prefix/perl$ps"
);
my
$cmd
=
"$cp $root/inst-$p$prefix/bin/* $bindir/"
;
$cmd
=
"$sudo $cmd"
if
$sudo
and !-w
"$bindir/perl$p"
;
$c
->_system(
$cmd
);
$c
->_system(
'mv'
,
"$root/inst-$p$prefix/perl$ps"
,
"$root/inst-$p$prefix/bin/perl$ps"
);
}
else
{
for
(
qw(cpan perldoc pod2man perlbug)
) {
my
@c
= (
$cp
,
"$root/inst-$p$prefix/bin/$_$ps"
,
"$bindir/"
);
unshift
@c
,
$sudo
if
$sudo
and !-w
"$bindir/perl$p"
;
$c
->_system1(
@c
);
}
}
@c
= (
$cp
,
"-rf"
,
"$root/inst-$p$prefix/lib"
,
"$prefix/"
);
my
$lib
=
$is_cperl
?
'cperl'
:
'perl5'
;
unshift
@c
,
$sudo
if
$sudo
and !-w
"$prefix/lib/$lib/$ps"
;
$c
->_system1(
@c
);
if
(!
$testerr
and
$srcdir
eq
"."
and -d
'.git'
) {
$c
->_system1(
"rm"
,
"-rf"
,
".git"
);
}
}
chdir
$cwd
;
$c
->_set_alias(
$p
);
print
$c
->output()
if
$c
->options->{verbose};
return
"$bindir/perl$p faked"
if
$dryrun
;
return
-f
"$bindir/perl$p"
?
"$bindir/perl$p installed"
:
"$bindir/perl$p failed to install"
;
}
sub
uninstall
:Help(
'sudo rm /usr/local/bin/perl<arg> and its archlibs'
)
{
my
$c
=
shift
;
for
my
$p
(@{
$c
->stash->{perlall}}) {
my
$bindir
=
$c
->config->{PERLALL_BINDIR};
$bindir
=
"/usr/local/bin"
unless
$bindir
;
$p
= basename(
$p
);
$c
->_fail(
"$bindir/$p does not exist"
)
unless
-e
"$bindir/$p"
;
my
$pq
=
$p
;
$pq
=~ s/([\@\$\%])/\\$1/;
my
$archlib
= `
$bindir
/
$pq
-MConfig -e
'print \$Config{archlibexp}'
`;
$archlib
= `
$bindir
/
$pq
-MConfig -e
'print \$Config{archlib}'
`
unless
$archlib
;
my
$sitearch
= `
$bindir
/
$pq
-MConfig -e
'print \$Config{sitearchexp}'
`;
if
(
$c
->options->{dryrun} or (-f
"$bindir/$p"
and -d
$archlib
)) {
$c
->_system0(
"sudo"
,
"rm"
,
"-rf"
,
"$bindir/$p"
,
$archlib
,
$sitearch
);
}
else
{
$c
->_fail(
"$p archlib $archlib did not exist"
);
}
my
$root
=
$c
->config->{PERLALL_BUILDROOT};
if
(-d
"$root/inst-$p"
) {
$c
->_system1(
"rm"
,
"-rf"
,
"$root/inst-$p"
);
}
if
(-d
"$root/build-$p"
) {
$c
->_log(
"rm"
,
"-rf"
,
"$root/build-$p"
);
}
print
"perl$p uninstalled\n"
;
}
}
sub
_smoke
{
my
(
$c
,
$p
,
$from
,
@j
) =
@_
;
return
"unimplemented"
;
}
sub
bench
:Help(
'NYI'
)
{
my
$c
=
shift
;
return
"unimplemented"
;
}
sub
init
:Help(
'Installs and updates basic CPAN modules'
)
{
my
$c
=
shift
;
$c
->addopts(
"cpan=s"
,
"deps"
);
my
@argv
= @{
$c
->argv};
my
$mods
=
@argv
?
join
(
" "
,
@argv
) :
$c
->config->{
'init-modules'
};
if
(!
@argv
and
$mods
=~ /`(.+?)`/) {
my
$sh
= `$1`;
$mods
=~ s/`(.+?)`/
$sh
/;
}
if
(
$c
->options->{deps}) {
my
$ack
=
q(ack -ho '(^\s*|\{\s*)
(
use
|
require
) ([\w:]+);' blib/lib t | perl -lpe
's/^\s*(\{|;|use|require)\s*//g;s/;?\s*\$//;'
|
sort
-u);
$mods
= `
$ack
`;
$mods
=
join
(
" "
,
split
(/\n/,
$mods
));
return
"no --deps found"
unless
$mods
;
}
return
"missing config init-modules"
unless
$mods
;
my
$cpan
=
$c
->options->{
'cpan'
};
$cpan
=
$c
->config->{
'cpan'
}
unless
$cpan
;
$c
->options->{verbose} = 1;
for
my
$p
(@{
$c
->stash->{perlall}}) {
$c
->_lognew(_short(
$p
));
if
(
$c
->_older(
$p
,
"5.8.1"
)) {
$cpan
=
'-MCPAN'
;
}
else
{
if
(!
$cpan
) {
if
(
qx($p -MApp::Cpan -e'print q(ok)
') eq
'ok'
) {
$cpan
=
'cpan'
;
}
elsif
(
qx($p -MApp::cpanminus -e'print q(ok)
') eq
'ok'
) {
$cpan
=
'cpanm'
;
}
else
{
$cpan
=
'-MCPAN'
;
}
}
}
if
(
$cpan
eq
'cpan'
) {
qx($p -MCPAN::SQLite -e'CPAN::SQLite->query(mode=>"dist",name=>"CPAN")
' 2>/dev/null);
if
($? >> 8) {
my
$nosql
=
"$ENV{HOME}/.cpan/CPAN/nosqlite.pm"
;
unless
( -f
$nosql
) {
$c
->_system(
"cp"
,
"$ENV{HOME}/.cpan/CPAN/MyConfig.pm"
,
$nosql
);
$c
->_grep(
"-i s/'use_sqlite' => q\[1\]/'use_sqlite' => q\[0\]/; print"
,
$nosql
);
}
$c
->_system1(
$p
,
"-S"
,
"cpan"
,
"-j"
,
$nosql
,
'DBI'
,
'DBD::SQLite'
);
}
}
if
(
$cpan
eq
'-MCPAN'
) {
$c
->_system1(
$p
,
"-MCPAN"
,
"-e"
,
"install qw($mods)"
);
}
else
{
$c
->_system1(
$p
,
"-S"
,
$cpan
,
split
(/\s+/,
$mods
));
}
}
$c
->_set_alias()
if
@{
$c
->stash->{perlall}} < 5;
}
sub
list
:Help(
'List all installed perlall versions'
)
{
my
$c
=
shift
;
warn
"additional arguments @{$c->argv} ignored\n"
if
@{
$c
->argv};
return
join
"\n"
, @{
$c
->stash->{perlall}};
}
sub
set
:Help(
'Set alias p in .perlall'
)
{
my
$c
=
shift
;
my
$p
=
pop
@{
$c
->argv};
warn
"additional arguments @{$c->argv} ignored\n"
if
@{
$c
->argv};
$c
->_set_alias(
$p
);
return
;
}
sub
do
:Help(
'Execute commands with all perls'
)
{
my
$c
=
shift
;
my
$argv
=
join
" "
,@{
$c
->argv};
return
"missing args"
unless
$argv
;
$c
->addopts(
"verbose|v"
,
"quiet|q"
,
"dryrun!"
,
'forked'
,
"gittag=s"
);
for
my
$p
(@{
$c
->stash->{perlall}}) {
$c
->_lognew(_short(
$p
));
local
$ENV
{p} =
$p
;
local
$c
->options->{quiet};
$c
->_system0(
"$p $argv"
);
}
$c
->_set_alias()
if
@{
$c
->stash->{perlall}} < 5;
}
sub
cpan
:Help(
'Call cpan with args for all perls'
)
{
my
$c
=
shift
;
my
$argv
=
join
" "
,@{
$c
->argv};
return
"missing args"
unless
$argv
;
$c
->options->{verbose} = 1
unless
$c
->options->{quiet};
for
my
$p
(@{
$c
->stash->{perlall}}) {
$c
->_lognew(_short(
$p
));
$c
->_system0(
$p
,
"-S"
,
"cpan"
, @{
$c
->argv});
}
$c
->_set_alias()
if
@{
$c
->stash->{perlall}} < 5;
}
sub
cpanm
:Help(
'Call cpanm with args for all perls'
)
{
my
$c
=
shift
;
my
$argv
=
join
" "
,@{
$c
->argv};
return
"missing args"
unless
$argv
;
$c
->options->{verbose} = 1
unless
$c
->options->{quiet};
for
my
$p
(@{
$c
->stash->{perlall}}) {
$c
->_lognew(_short(
$p
));
$c
->_system0(
$p
,
"-S"
,
"cpanm"
, @{
$c
->argv});
}
$c
->_set_alias()
if
@{
$c
->stash->{perlall}} < 5;
}
sub
_gitoneliner {
my
$c
=
shift
;
return
$c
->options->{gittag}
if
$c
->options->{gittag};
if
(-d
'.svn'
) {
return
`svn info t |
grep
Revision`;
}
elsif
(-d
'.git'
) {
my
$s
= `git describe --long --tags --dirty --always`;
chomp
$s
;
$s
.= `git
log
--oneline -1`;
return
$s
;
}
else
{
return
''
;
}
}
sub
_make {
my
$c
=
shift
;
my
$p
=
shift
;
my
$verbose
=
shift
;
my
$make
=
$Config
{make};
$c
->_system(
$make
,
"-s"
,
"clean"
)
if
-f
"Makefile"
;
$c
->_lognew(_short(
$p
))
unless
$c
->stash->{log_fh};
if
(-f
"Makefile.PL"
) {
$c
->_system0(
$p
,
"Makefile.PL"
);
$verbose
?
$c
->_system1(
$make
) :
$c
->_system(
$make
);
}
elsif
(-f
"Build.PL"
) {
$c
->_system(
"./Build"
,
"realclean"
)
if
-f
"Build"
;
$c
->_system(
"rm"
,
"-rf"
,
"blib"
,
"_Build"
,
"Build"
)
if
$^O ne
'MSWin32'
;
$c
->_system0(
$p
,
"Build.PL"
);
$verbose
?
$c
->_system1(
$p
,
"Build"
) :
$c
->_system(
$p
,
"Build"
);
}
}
sub
make
:Help(
'Do perl Makefile.PL; make for all perls'
)
{
my
$c
=
shift
;
my
$argv
=
join
" "
,@{
$c
->argv};
my
$make
=
$Config
{make};
$c
->addopts(
"verbose|v"
,
"quiet|q"
,
"dryrun!"
,
'forked'
,
"gittag=s"
);
my
$gitshort
=
$c
->_gitoneliner();
my
$v
=
$c
->options->{verbose};
for
my
$p
(@{
$c
->stash->{perlall}}) {
$c
->_lognew(_short(
$p
));
my
$fh
=
$c
->stash->{log_fh};
print
$fh
$gitshort
if
$fh
and
$gitshort
;
$c
->_make(
$p
,!
$c
->options->{quiet});
if
(
$argv
) {
local
$ENV
{p} =
$p
;
local
$c
->options->{quiet};
local
$c
->options->{verbose} =
$v
;
$c
->_system0(
"$p $argv"
);
}
}
$c
->_set_alias()
if
@{
$c
->stash->{perlall}} < 5;
}
sub
maketest
:Help(
'Do make; make test for all perls'
)
{
my
$c
=
shift
;
my
$make
=
$Config
{make};
$c
->addopts(
"verbose|v"
,
"quiet|q"
,
"dryrun!"
,
'forked'
,
"gittag=s"
);
my
$gitshort
=
$c
->_gitoneliner();
my
$v
=
$c
->options->{verbose};
for
my
$p
(@{
$c
->stash->{perlall}}) {
$c
->_lognew(_short(
$p
));
my
$fh
=
$c
->stash->{log_fh};
print
$fh
$gitshort
if
$fh
and
$gitshort
;
$c
->_make(
$p
,
$v
);
my
@opts
= (
"test"
,
$v
?
"TEST_VERBOSE=1"
: ());
unshift
@opts
,
"-j"
.
$c
->options->{j}
if
$c
->options->{j} and !
$c
->_older(
$p
,
"5.10.0"
);
if
(!-f
"Makefile"
and -f
"Build"
) {
$c
->_system1(
$p
,
"Build"
,
@opts
);
}
else
{
$c
->_system1(
$make
,
@opts
);
}
if
(
$c
->options->{quiet}) {
my
$log
=
$c
->stash->{
log
};
my
$result
= `
grep
-a Result:
$log
`;
$c
->_log(0,
$result
)
if
$result
;
}
if
(@{
$c
->argv}) {
local
$c
->options->{quiet};
local
$c
->options->{verbose} =
$v
;
$c
->_system0(
"p=$p $p @{$c->argv}"
);
}
if
(-d
'.svn'
and
$fh
) {
print
$fh
`svn info t |
grep
Revision`;
print
$fh
`svn diff -x -w`
if
-d
'.svn'
;
}
elsif
(-d
'.git'
and
$fh
) {
print
$fh
`git
log
-1`;
print
$fh
`git diff`;
}
print
$fh
`
$p
-V`
if
$fh
;
}
`./store_rpt`
if
-f
'store_rpt'
;
$c
->_set_alias()
if
@{
$c
->stash->{perlall}} < 5;
}
sub
makeinstall
:Help(
'Do make test && sudo make install for all perls'
)
{
my
$c
=
shift
;
my
$make
=
$Config
{make};
$c
->addopts(
"force|f"
,
"notest|n"
);
my
$gitshort
=
$c
->_gitoneliner();
my
$sudo
=
$c
->config->{sudo};
my
$v
=
$c
->options->{verbose};
for
my
$p
(@{
$c
->stash->{perlall}}) {
$c
->_lognew(_short(
$p
));
local
$c
->options->{verbose} =
$v
;
my
$fh
=
$c
->stash->{log_fh};
print
$fh
$gitshort
if
$fh
and
$gitshort
;
$c
->_make(
$p
);
my
$instcmd
=
"$sudo $make install"
;
if
(
$c
->options->{notest}) {
$c
->options->{verbose} = 1
unless
$c
->options->{quiet};
$c
->_system1(
$instcmd
);
}
elsif
(
$c
->options->{force}) {
$c
->_system1(
$make
,
'test'
);
$c
->options->{verbose} = 1
unless
$c
->options->{quiet};
$c
->_system1(
$instcmd
);
}
else
{
$c
->options->{verbose} = 1
unless
$c
->options->{quiet};
$c
->_system1(
"$make test && $instcmd"
);
}
if
(@{
$c
->argv}) {
local
$ENV
{p} =
$p
;
$c
->_system0(
$p
, @{
$c
->argv} );
}
}
$c
->_set_alias()
if
@{
$c
->stash->{perlall}} < 5;
}
sub
_startvm {
my
$c
=
shift
;
my
$m
=
shift
or
die
"_startvm missing vm name"
;
my
$ctl
=
$c
->config->{testvm_ctl};
unless
(
$ctl
) {
$c
->_log(
''
,
"no testvm_ctl in .perlall. _startvm $m skipped"
);
return
1;
}
$c
->_fail(
"Unsupported testvm_ctl='$ctl' in .perlall. Only virsh."
)
if
$ctl
ne
'virsh'
;
my
$status
= `sudo virsh list --all`;
my
$test
= '
Id Name State
----------------------------------
14 win running
15 freebsd7 paused
18 centos6 paused
22 centos5 paused
24 centos4 paused
25 solaris running
- freebsd8 shut off
- openbsd49 shut off';
my
$max
=
$c
->options->{max};
my
(
@running
);
my
@status
=
split
/\n/,
$status
;
if
(
$max
) {
for
(
@status
) {
my
@v
=
split
/\s+/;
shift
@v
if
$v
[0] eq
''
;
push
@running
,
$v
[1]
if
$v
[2] eq
'running'
;
}
}
for
(
@status
) {
my
@v
=
split
/\s+/;
shift
@v
if
$v
[0] eq
''
;
if
(
$v
[1] eq
$m
) {
if
(
$v
[2] eq
'running'
) {
return
1;
}
elsif
(
$v
[2] eq
'paused'
) {
if
(
$max
and
@running
>
$max
) {
my
$r
=
shift
@running
;
$c
->_system1(
qw(sudo virsh suspend)
,
$r
);
push
@{
$c
->stash->{vm}}, [
$m
,
'suspend'
];
}
$c
->_system1(
qw(sudo virsh resume)
,
$m
);
sleep
0.1;
unshift
@running
,
$m
;
return
1;
}
elsif
(
$v
[2] eq
'shut'
) {
if
(
$max
and
@running
>
$max
) {
my
$r
=
shift
@running
;
$c
->_system1(
qw(sudo virsh suspend)
,
$r
);
push
@{
$c
->stash->{vm}}, [
$m
,
'shutdown'
];
}
$c
->_system1(
qw(sudo virsh start)
,
$m
);
sleep
25;
unshift
@running
,
$m
;
return
1;
}
else
{
$c
->_fail(
"vm $m in invalid state $v[2]"
);
return
;
}
}
}
$c
->debug(
"vm $m not found"
);
return
1;
}
sub
_vm_prevstatus {
my
$c
=
shift
;
my
$m
=
shift
or
die
"_vm_prevstatus missing vm name"
;
while
(@{
$c
->stash->{vm}}) {
my
$a
=
shift
@{
$c
->stash->{vm}};
return
$a
->[1]
if
$a
->[0] eq
$m
;
}
}
sub
_vm_delstatus {
my
$c
=
shift
;
my
$m
=
shift
or
die
"_vm_delstatus missing vm name"
;
my
@v
=
grep
{
$_
->[0] ne
$m
} @{
$c
->stash->{vm}};
$c
->stash->{vm} = \
@v
;
}
sub
testvm
:Help(
'Test on remote accounts via ssh/rsync (vm or host)'
)
{
my
$c
=
shift
;
my
$gopts
= _opts(
$c
->options);
$c
->addopts(
"all|a"
,
"up"
,
"prefix|p=s"
,
"cmd|c=s"
,
"option|o=s"
,
"max|j=n"
,
"fork!"
);
my
(
$base
);
my
@testvm
=
split
/ /,
$c
->config->{testvm_all};
my
@machines
=
$c
->options->{all} ?
@testvm
: @{
$c
->argv};
return
"missing args"
unless
@machines
;
$c
->options->{max} =
$c
->config->{testvm_max}
unless
$c
->options->{max};
my
$opts
= _opts(
$c
->options);
$opts
=~ s/
$_
//
for
split
/ /,
$gopts
;
$gopts
=
" "
.
$gopts
if
$gopts
;
_print(1,
"perlall$gopts testvm "
.
$opts
,
@machines
)
if
$c
->options->{verbose};
$c
->_lognew(
''
);
my
$cmd
=
$c
->options->{cmd} ||
"maketest"
;
my
$opt
=
$c
->options->{option} ? (
' '
.
$c
->options->{option}) :
' -q'
;
my
$man
=
'MANIFEST'
;
$c
->_fail(
"$man not found"
)
unless
-f
$man
;
my
$f
=
'MANIFEST.files'
;
if
( ! -f
$f
or -M
$man
< -M
$f
) {
$c
->_log(1,
"Creating $f"
);
open
M,
'<'
,
$man
;
open
F,
'>'
,
$f
;
while
(<M>) {
s/ +$//;
s/^(\S+)(\s+.+)$/$1/;
print
F
$_
unless
/^
}
close
M;
close
F;
}
my
$home
=
$ENV
{HOME};
if
(!
$home
or !-d
$home
) {
_auto_use(
'File::HomeDir'
);
$home
= File::HomeDir->my_home;
}
if
(File::Spec->can(
'abs2rel'
) and
$home
) {
my
$cwd
= Cwd::getcwd();
$base
= File::Spec->abs2rel(
$cwd
,
$home
);
if
(
length
(
$cmd
) <
length
(
$base
)) {
$base
=
$cwd
;
}
}
else
{
my
$vmprefix
=
$c
->options->{testvm_prefix} ||
"Perl"
;
$base
= File::Spec->catdir(
$vmprefix
, basename(Cwd::getcwd()));
}
my
$msg
=
"done"
;
my
$remotecmd
=
"cd $base && touch Makefile.PL && perlall$gopts $cmd$opt"
;
my
$up
=
$c
->options->{up};
my
$do_fork
=
$c
->options->{
fork
} and IPC::Cmd->can_use_run_forked();
my
$gitshort
=
$c
->_gitoneliner();
my
$fh
=
$c
->stash->{log_fh};
print
$fh
$gitshort
if
$fh
and
$gitshort
;
my
@forked
;
for
my
$m
(
@machines
) {
$c
->_startvm(
$m
) or
next
;
$c
->_system1(
"rsync"
,
"-avzL"
,
"--delete"
,
'--files-from=MANIFEST.files'
,
'.'
,
"$m:$base/"
) or
next
;
unless
(
$up
) {
my
$logglob
=
$cmd
eq
'maketest'
?
"log.test-*"
:
"log.$cmd-*"
;
if
(
$gitshort
and
$remotecmd
!= /--gittag/) {
my
(
$commit
) =
split
/ /,
$gitshort
;
$remotecmd
.=
" --gittag=$commit"
;
}
if
(
$do_fork
) {
$remotecmd
.=
' --forked'
if
$cmd
eq
'maketest'
and
$cmd
!~ /--forked/;
my
@cmd
= (
"sh"
,
"-c"
,
"if ssh $m '$remotecmd'; then rsync -avz $m:$base/$logglob .; grep Result $logglob; fi"
);
if
(
$c
->stash->{vm} and
my
$prevstat
=
$c
->_vm_prevstatus(
$m
)) {
@cmd
= (
"sh"
,
"-c"
,
"if ssh $m '$remotecmd'; then rsync -avz $m:$base/$logglob .; grep Result $logglob; "
.
"sudo virsh $m $prevstat; fi"
);
_vm_delstatus(
$m
);
}
my
$pid
;
FORK:
{
if
(
$pid
=
fork
) {
$c
->debug(
"forked $pid"
);
push
@forked
,
$pid
;
$msg
=
"forked"
;
$c
->_log(0,
"forked $remotecmd on $m"
);
}
elsif
(
defined
$pid
) {
exec
@cmd
;
}
elsif
($! ==
&Fcntl::EAGAIN
) {
sleep
5;
redo
FORK;
}
else
{
die
"Can't fork: $!\n"
;
}
}
}
else
{
$c
->_system1(
"ssh"
,
$m
,
$remotecmd
);
$c
->_system1(
"rsync"
,
"-avz"
,
"$m:$base/$logglob"
,
"."
);
$c
->_system1(
"grep Result $logglob"
);
}
}
}
if
(!
@forked
and
$c
->stash->{vm}) {
while
(@{
$c
->stash->{vm}}) {
my
$a
=
shift
@{
$c
->stash->{vm}};
$c
->_system1(
qw(sudo virsh)
,
$a
->[1],
$a
->[0]);
}
}
"testvm $cmd $msg on "
.
join
(
" "
,
@machines
)
}
sub
initvm
:Help(
'Init remote perlall via ssh/rsync (vm or host)'
)
{
my
$c
=
shift
;
$c
->addopts(
"all|a"
,
"max|j=n"
);
my
@m
=
$c
->options->{all} ?
split
(/ /,
$c
->config->{testvm_all}) : @{
$c
->argv};
return
"missing host"
unless
@m
;
$c
->options->{max} =
$c
->config->{testvm_max}
unless
$c
->options->{max};
$c
->_lognew(
''
);
for
my
$m
(
@m
) {
_print(0,
"perlall initvm $m"
)
unless
$c
->options->{quiet};
$c
->_startvm(
$m
) or
next
;
unless
(`ssh
$m
ls .ssh/authorized_keys` =~ /authorized_keys$/m) {
for
my
$t
(/ecdsa dsa rsa/) {
if
(-f
"$ENV{HOME}/.ssh/id_$t.pub"
) {
_print 1,
"rsync -avzL ~/.ssh/id_$t.pub >>$m:.ssh/authorized_keys"
unless
$c
->options->{quiet};
qx(rsync -avzL $ENV{HOME}/.ssh/id_$t.pub $m:.ssh/copied.pub)
;
qx(ssh $m cat .ssh/copied.pub >> .ssh/authorized_keys)
;
last
}
}
}
$c
->_system1(
"rsync"
,
"-avzL"
,$0,
"$m:bin/perlall"
) or
next
;
unless
(`ssh
$m
ls .perlall` =~ /.perlall$/m) {
$c
->_system1(
"rsync"
,
"-avzL"
,
"$ENV{HOME}/.perlall"
,
"$m:.perlall"
);
}
$c
->_system1(
"ssh $m "
.
"'perl -MCPAN -e\"install qw/"
.
join
(
" "
,
@extuse
).
"/\"'"
);
my
$patchperlpath
= `ssh
$m
perldoc -l Devel::PatchPerl`;
chomp
$patchperlpath
;
$patchperlpath
=~ s|PatchPerl\.pm|PatchPerl/Plugin|;
my
$patchasan
= `perldoc -l Devel::PatchPerl::Plugin::Asan`;
chomp
$patchasan
;
die
"Devel::PatchPerl::Plugin::Asan missing\n"
unless
$patchasan
;
my
$patchperlall
= `perldoc -l Devel::PatchPerl::Plugin::perlall`;
chomp
$patchperlall
;
die
"Devel::PatchPerl::Plugin::perlall missing\n"
unless
$patchperlall
;
$c
->_system1(
"ssh"
,
$m
,
"mkdir -p $patchperlpath"
);
$c
->_system1(
"rsync"
,
"-avz"
,
$patchasan
,
"$m:$patchperlpath/Asan.pm"
);
$c
->_system1(
"rsync"
,
"-avz"
,
$patchperlall
,
"$m:$patchperlpath/perlall.pm"
);
}
while
(
$c
->stash->{vm} and @{
$c
->stash->{vm}}) {
my
$a
=
shift
@{
$c
->stash->{vm}};
$c
->_system1(
qw(sudo virsh)
,
$a
->[1],
$a
->[0]);
}
"initvm done on "
.
join
(
" "
,
@m
)
}
sub
config
:Help(
'Print (or update - not yet) config'
)
{
my
$c
=
shift
;
$c
->addopts(
'options|o'
);
my
$file
=
".perlall="
;
for
(
"/etc/perlall"
,
"$ENV{HOME}/.perlall"
) {
$file
.=
$_
.
":"
if
-f
$_
;
}
print
substr
(
$file
,0,-1),
"\n"
;
for
(
keys
%{
$c
->config}) {
print
$_
,
"="
,
$c
->config->{
$_
},
"\n"
;
}
if
(
$c
->options->{options}) {
delete
$c
->options->{options};
for
(
keys
%{
$c
->options}) {
print
$_
,
"="
,
$c
->options->{
$_
},
"\n"
;
}
}
}
sub
selfupgrade
:Help(
'Upgrade perlall to its latest or stable version'
)
{
my
$c
=
shift
;
$c
->addopts(
'latest|l'
);
my
$branch
=
$c
->options->{latest} ?
'master'
:
'release'
;
$c
->_system(
"wget"
,
"--no-check-certificate"
,
"-O"
,
"perlall.tmp"
,
if
(-s
"perlall.tmp"
> 5000) {
$c
->_system(
"chmod"
,
"0755"
,
"perlall.tmp"
);
$c
->_system(
"mv"
,
"perlall.tmp"
,-l $0 ?
readlink
($0) : $0) or
"$0 updated"
}
else
{
"wget download from github failed"
}
}
sub
help
:Help(
'List of commands. With -v more'
)
{
my
$c
=
shift
;
$c
->addopts(
'verbose|v'
);
return
Pod::Usage::pod2usage
( {
-message
=> App::Rad::Help::usage() .
"\n\n"
. App::Rad::Help::helpstr(
$c
),
-verbose
=>
$c
->options->{verbose} ? 3 : 0,
} );
}
sub
version
:Help(
'Print version'
)
{
print
basename($0).
" $main::VERSION\n"
;
exit
;
}