use
t_Common
qw/oops mytempfile mytempdir/
;
BEGIN{
confess
"Test::More already loaded!"
if
defined
(
&Test::More::ok
);
confess
"Test2::V0 already loaded!"
if
defined
(
&Test2::V0::import
);
binmode
(STDIN,
":encoding(UTF-8)"
);
binmode
(STDOUT,
":encoding(UTF-8)"
);
binmode
(STDERR,
":encoding(UTF-8)"
);
STDERR->autoflush(1);
STDOUT->autoflush(1);
}
our
@EXPORT
=
qw/silent
bug
t_ok t_is t_like
ok_with_lineno is_with_lineno like_with_lineno
rawstr showstr showcontrols displaystr
show_white show_empty_string
fmt_codestring
verif_no_internals_mentioned
insert_loc_in_evalstr verif_eval_err
timed_run
mycheckeq_literal expect1 mycheck _mycheck_end
arrays_eq hash_subset
run_perlscript
@quotes
string_to_tempfile
/
;
our
@EXPORT_OK
=
qw/$debug $silent $verbose dprint dprintf/
;
use
Cwd
qw/getcwd abs_path/
;
sub
bug(@) {
@_
=(
"BUG FOUND:"
,
@_
);
goto
&Carp::confess
}
my
@orig_ARGV
=
@ARGV
;
our
(
$debug
,
$verbose
,
$silent
,
$nonrandom
);
Getopt::Long::Configure(
"pass_through"
);
GetOptions(
"d|debug"
=>
sub
{
$debug
=
$verbose
=1;
$silent
=0 },
"s|silent"
=> \
$silent
,
"n|nonrandom"
=> \
$nonrandom
,
"v|verbose"
=> \
$verbose
,
) or
die
"bad args"
;
Getopt::Long::Configure(
"default"
);
if
(
$nonrandom
) {
if
(
open
my
$fh
,
"<"
,
"/proc/sys/kernel/randomize_va_space"
) {
chomp
(
my
$setting
= <
$fh
>);
unless
(
$setting
eq
"0"
) {
warn
"WARNING: Kernel address space randomization is in effect.\n"
;
warn
"To disable: echo 0 | sudo tee /proc/sys/kernel/randomize_va_space\n"
;
warn
"To re-enable echo 2 | sudo tee /proc/sys/kernel/randomize_va_space\n"
;
}
}
unless
((
$ENV
{PERL_PERTURB_KEYS}//
""
) eq
"2"
) {
$ENV
{PERL_PERTURB_KEYS} =
"2"
;
$ENV
{PERL_HASH_SEED} =
"0xDEADBEEF"
;
$ENV
{PERL5LIB} =
join
(
":"
,
@INC
);
exec
$^X, $0,
@orig_ARGV
;
}
}
sub
import
{
my
$target
=
caller
;
eval
'$['
//
die
;
Test2::V0->
import
::into(
$target
,
-no_warnings
=> 1,
(
map
{
"!$_"
}
"A"
..
"AAZ"
)
);
Test2::Plugin::BailOnFail->
import
::into(
$target
);
if
(
grep
{
$_
eq
':silent'
}
@_
) {
@_
=
grep
{
$_
ne
':silent'
}
@_
;
_start_silent()
unless
$debug
;
}
goto
&Exporter::import
}
sub
dprint(@) {
print
(
@_
)
if
$debug
};
sub
dprintf($@) {
printf
(
$_
[0],
@_
[1..
$#_
])
if
$debug
};
sub
arrays_eq($$) {
my
(
$a
,
$b
) =
@_
;
return
0
unless
@$a
==
@$b
;
for
(
my
$i
=0;
$i
<=
$#$a
;
$i
++) {
return
0
unless
$a
->[
$i
] eq
$b
->[
$i
];
}
return
1;
}
sub
hash_subset($@) {
my
(
$hash
,
@keys
) =
@_
;
return
undef
if
!
defined
$hash
;
return
{
map
{
exists
(
$hash
->{
$_
}) ? (
$_
=>
$hash
->{
$_
}) : () }
@keys
}
}
sub
string_to_tempfile($@) {
my
(
$string
,
@tfargs
) =
@_
;
my
(
$fh
,
$path
) = mytempfile(
@tfargs
);
dprint
"> Creating $path\n"
;
print
$fh
$string
;
$fh
->flush;
seek
(
$fh
,0,0) or
die
"seek $path : $!"
;
wantarray
? (
$path
,
$fh
) :
$path
}
sub
run_perlscript(@) {
my
@perlargs
=
@_
;
unshift
@perlargs
,
"-MCarp=verbose"
if
$Carp::Verbose
;
local
$ENV
{PERL5LIB} =
join
(
":"
,
@INC
);
system
$^X,
@perlargs
;
}
my
(
$orig_stdOUT
,
$orig_stdERR
,
$orig_DIE_trap
);
my
(
$inmem_stdOUT
,
$inmem_stdERR
) = (
""
,
""
);
my
$silent_mode
;
use
Encode
qw/decode FB_WARN FB_PERLQQ FB_CROAK LEAVE_SRC/
;
sub
_finish_silent() {
confess
"not in silent mode"
unless
$silent_mode
;
close
STDERR;
open
(STDERR,
">>&"
,
$orig_stdERR
) or
exit
(198);
close
STDOUT;
open
(STDOUT,
">>&"
,
$orig_stdOUT
) or
die
"orig_stdOUT: $!"
;
$SIG
{__DIE__} =
$orig_DIE_trap
;
$silent_mode
= 0;
my
$errmsg
;
if
(
$inmem_stdOUT
ne
""
) {
print
STDOUT
"--- saved STDOUT ---\n"
;
print
STDOUT decode(
"utf8"
,
$inmem_stdOUT
, FB_PERLQQ|LEAVE_SRC);
$errmsg
//=
"Silence expected on STDOUT"
;
}
if
(
$inmem_stdERR
ne
""
) {
print
STDERR
"--- saved STDERR ---\n"
;
print
STDERR decode(
"utf8"
,
$inmem_stdERR
, FB_PERLQQ|LEAVE_SRC);
$errmsg
=
$errmsg
?
"$errmsg and STDERR"
:
"Silence expected on STDERR"
;
}
$errmsg
}
sub
_start_silent() {
confess
"nested silent treatments not supported"
if
$silent_mode
;
$silent_mode
= 1;
$orig_DIE_trap
=
$SIG
{__DIE__};
$SIG
{__DIE__} =
sub
{
return
if
$^S or !
defined
($^S);
my
@diemsg
=
@_
;
my
$err
=_finish_silent();
warn
$err
if
$err
;
die
@diemsg
;
};
my
@OUT_layers
=
grep
{
$_
ne
"unix"
} PerlIO::get_layers(
*STDOUT
,
output
=>1);
open
(
$orig_stdOUT
,
">&"
, \
*STDOUT
) or
die
"dup STDOUT: $!"
;
close
STDOUT;
open
(STDOUT,
">"
, \
$inmem_stdOUT
) or
die
"redir STDOUT: $!"
;
binmode
(STDOUT);
binmode
(STDOUT,
":utf8"
);
my
@ERR_layers
=
grep
{
$_
ne
"unix"
} PerlIO::get_layers(
*STDERR
,
output
=>1);
open
(
$orig_stdERR
,
">&"
, \
*STDERR
) or
die
"dup STDERR: $!"
;
close
STDERR;
open
(STDERR,
">"
, \
$inmem_stdERR
) or
die
"redir STDERR: $!"
;
binmode
(STDERR);
binmode
(STDERR,
":utf8"
);
}
sub
silent(&) {
my
$wantarray
=
wantarray
;
my
$code
=
shift
;
_start_silent();
my
@result
=
do
{
if
(
defined
$wantarray
) {
return
(
$wantarray
?
$code
->() :
scalar
(
$code
->()) );
}
$code
->();
my
$dummy_result
;
};
my
$errmsg
= _finish_silent();
local
$Test::Builder::Level
=
$Test::Builder::Level
+ 1;
Test2::V0::ok(!
defined
(
$errmsg
),
$errmsg
);
wantarray
?
@result
:
$result
[0]
}
END{
if
(
$silent_mode
) {
my
$errmsg
= _finish_silent();
if
(
$errmsg
) {
warn
$errmsg
;
exit
199;
}
}
}
dirname(abs_path(__FILE__)) =~ m
(
my
$testee_top_module
= $1) =~ s/-/::/g;
oops
unless
$testee_top_module
;
sub
verif_no_internals_mentioned($) {
my
$original
=
shift
;
return
if
$Carp::Verbose
;
local
$_
=
$original
;
s/(?<!\\)\\\*\{
"[^"
]*"\}//g;
s/(?<!\\)\*\w[\w:\$]*\b//g;
s/(?<!\w)\w[\w:\$]*=(?:REF|ARRAY|HASH|SCALAR|CODE|GLOB)\(0x[0-9a-f]+\)//g;
s/(?<!\w)\w[\w:\$]*<\d+:[\da-f]+>//g;
s
my
$msg
;
if
(/\b(?<hit>${testee_top_module}::[\w:]*)/) {
$msg
=
"ERROR: Log msg or traceback mentions internal package '$+{hit}'"
}
elsif
(/(?<hit>[-.\w\/]+\.pm\b)/s) {
$msg
=
"ERROR: Log msg or traceback mentions non-test .pm file '$+{hit}'"
}
if
(
$msg
) {
my
$start
= $-[1];
my
$end
= $+[1];
substr
(
$_
,
$start
,0) =
"HERE>>>"
;
substr
(
$_
,
$end
+7,0) =
"<<<THERE"
;
local
$Carp::Verbose
= 0;
$Carp::CarpLevel
++;
croak
$msg
,
":\n«$_»\n"
;
}
1
}
sub
show_empty_string(_) {
$_
[0] eq
""
?
"<empty string>"
:
$_
[0]
}
sub
show_white(_) {
local
$_
=
shift
;
return
"(Is undef)"
unless
defined
;
s/\t/<tab>/sg;
s/( +)$/
"<space>"
x
length
($1)/seg;
s/\n/<newline>\n/sg;
show_empty_string
$_
}
our
$showstr_maxlen
= INT_MAX;
our
@quotes
= (
"«"
,
"»"
);
sub
rawstr(_) {
my
$text
=
$_
[0];
$quotes
[0].(
length
(
$text
)>
$showstr_maxlen
?
substr
(
$text
,0,
$showstr_maxlen
-3).
"..."
:
$text
).
$quotes
[1]
}
sub
showcontrols(_) {
local
$_
=
shift
;
s/\n/\N{U+2424}/sg;
s/[\x{00}-\x{1F}]/
chr
(
ord
($&)+0x2400 ) /aseg;
rawstr
}
sub
showstr(_) {
if
(
defined
&Data::Dumper::Interp::visnew
) {
return
visnew->Useqq(
"unicode"
)->vis(
shift
);
}
else
{
return
showcontrols(
shift
);
}
}
sub
displaystr($) {
my
(
$input
) =
@_
;
return
"undef"
if
!
defined
(
$input
);
local
$_
;
state
$utf8_output
=
grep
/utf.?8/i, PerlIO::get_layers(
*STDOUT
,
output
=>1);
my
$r
= rawstr(
$input
);
if
(!
$utf8_output
&&
$input
=~ /[^[:
print
:]]/a) {
my
$dd
= Data::Dumper->new([
$input
])->Useqq(1)->Terse(1)->Indent(0)->Dump;
if
(
$dd
ne
$input
&&
$dd
ne
"\"$input\""
) {
$r
.=
"\nD::D->$dd"
;
}
}
$r
}
sub
fmt_codestring($;$) {
my
(
$str
,
$prefix
) =
@_
;
$prefix
//=
"line "
;
my
$i
;
map
{
sprintf
"%s%2d: %s\n"
,
$prefix
,++
$i
,
$_
} (
split
/\n/,
$_
[0]);
}
sub
t_ok($;$) {
my
(
$isok
,
$test_label
) =
@_
;
my
$lno
= (
caller
)[2];
$test_label
= (
$test_label
//
""
) .
" (line $lno)"
;
@_
= (
$isok
,
$test_label
);
goto
&Test2::V0::ok
;
}
sub
ok_with_lineno($;$) {
goto
&t_ok
};
sub
t_is($$;$) {
my
(
$got
,
$exp
,
$test_label
) =
@_
;
my
$lno
= (
caller
)[2];
$test_label
= (
$test_label
//
$exp
//
"undef"
) .
" (line $lno)"
;
@_
= (
$got
,
$exp
,
$test_label
);
goto
&Test2::V0::is
;
}
sub
is_with_lineno($$;$) {
goto
&t_is
}
sub
t_like($$;$) {
my
(
$got
,
$exp
,
$test_label
) =
@_
;
my
$lno
= (
caller
)[2];
$test_label
= (
$test_label
//
$exp
) .
" (line $lno)"
;
@_
= (
$got
,
$exp
,
$test_label
);
goto
&Test2::V0::like
;
}
sub
like_with_lineno($$;$) {
goto
&t_like
}
sub
_mycheck_end($$$) {
my
(
$errmsg
,
$test_label
,
$ok_only_if_failed
) =
@_
;
return
if
$ok_only_if_failed
&& !
$errmsg
;
my
$lno
= (
caller
)[2];
&Test2::V0::diag
(
"**********\n${errmsg}***********\n"
)
if
$errmsg
;
@_
= ( !
$errmsg
,
$test_label
);
goto
&ok_with_lineno
;
}
sub
mycheckeq_literal($$$) {
my
(
$desc
,
$exp
,
$act
) =
@_
;
$exp
= show_white(
$exp
);
$act
= show_white(
$act
);
return
unless
$exp
ne
$act
;
my
$hposn
= 0;
my
$vposn
= 0;
for
(0..
length
(
$exp
)) {
my
$c
=
substr
(
$exp
,
$_
,1);
last
if
$c
ne
substr
(
$act
,
$_
,1);
++
$hposn
;
if
(
$c
eq
"\n"
) {
$hposn
= 0;
++
$vposn
;
}
}
@_
= (
"\n**************************************\n"
.(
$desc
?
"${desc}\n"
:
""
)
.
"Expected:\n"
.displaystr(
$exp
).
"\n"
.
"Actual:\n"
.displaystr(
$act
).
"\n"
.(
" "
x (
$hposn
+
length
(
$quotes
[0]))).
"^"
.(
$vposn
> 0 ?
"(line "
.(
$vposn
+1).
")\n"
:
"\n"
)
.
" at line "
, (
caller
(0))[2].
"\n"
) ;
Carp::confess(
@_
);
}
sub
expect1($$) {
@_
= (
""
,
@_
);
goto
&mycheckeq_literal
;
}
our
$bs
=
'\\'
;
sub
_expstr2restr($) {
local
$_
=
shift
;
confess
"bug"
if
ref
(
$_
);
s/\\/<BS>/g;
$_
=
'\Q'
.
$_
.
'\E'
;
s
if
(m
s
or confess
"Problem with qr/.../ in input string: $_"
;
}
if
(m
s{(\w+)=<BS>\*\{
"(::)<BS>([^"
]+)"\}}
{$1=<BS>*{\\E(?x:
"(?:main::|::) \\Q<BS>$3"
\\E |
'(?:main::|::) \\Q$3'
\\E )\\Q}}xg
|
s{(\w+)=<BS>\*\{
"(\w[\w:]*::)<BS>([^"
]+)"\}}
{$1=<BS>*{\\E(?x:
"\\Q$2<BS>$3"
\\E |
'\\Q$2$3'
\\E )\\Q}}xg
or
confess
"Problem with filehandle in input string <<$_>>"
;
}
s/<BS>\\/\${bs}\\/g;
s/<BS>/\\/g;
$_
}
sub
expstr2re($) {
my
$input
=
shift
;
my
$xdesc
;
my
$output
;
if
(
$input
!~ m
$output
=
$input
;
$xdesc
=
""
;
}
else
{
my
$s
= _expstr2restr(
$input
);
my
$saved_dollarat
= $@;
my
$re
=
eval
"qr{$s}"
;
die
"$@ "
if
$@;
$@ =
$saved_dollarat
;
$xdesc
=
"**Orig match str :"
.displaystr(
$input
).
"\n"
.
"**Generated re str:"
.displaystr(
$s
).
"\n"
;
$output
=
$re
;
}
wantarray
? (
$xdesc
,
$output
) :
$output
}
sub
mycheck($$@) {
my
(
$desc
,
$expected_arg
,
@actual
) =
@_
;
local
$_
;
my
@expected
=
ref
(
$expected_arg
) eq
"ARRAY"
?
@$expected_arg
: (
$expected_arg
);
if
($@) {
local
$_
;
confess
"Eval error: $@\n"
unless
$@ =~ /fake/i;
}
confess
"zero 'actual' results"
if
@actual
==0;
confess
"ARE WE USING THIS FEATURE? (@actual)"
if
@actual
!= 1;
confess
"ARE WE USING THIS FEATURE? (@expected)"
if
@expected
!= 1;
confess
"\nTESTa FAILED: $desc\n"
.
"Expected "
.
scalar
(
@expected
).
" results, but got "
.
scalar
(
@actual
).
":\n"
.
"expected=(@expected)\n"
.
"actual=(@actual)\n"
.
"\$@=$@\n"
if
@expected
!=
@actual
;
foreach
my
$i
(0..
$#actual
) {
my
$actual
=
$actual
[
$i
];
my
$expected
=
$expected
[
$i
];
my
$xdesc
=
""
;
if
(!
ref
(
$expected
)) {
(
$xdesc
,
$expected
) = expstr2re(
$expected
);
}
if
(
ref
(
$expected
) eq
"Regexp"
) {
unless
(
$actual
=~
$expected
) {
@_
= (
"\n**************************************\n"
.
"TESTb FAILED: "
.
$desc
.
"\n"
.
"Expected (Regexp):\n"
.${expected}.
"<<end>>\n"
.
$xdesc
.
"Got:\n"
.displaystr(
$actual
).
"<<end>>\n"
) ;
Carp::confess(
@_
);
}
}
else
{
unless
(
$expected
eq
$actual
) {
@_
= (
"TESTc FAILED: $desc"
,
$expected
,
$actual
);
goto
&mycheckeq_literal
}
}
}
}
sub
verif_eval_err(;$) {
my
(
$msg_regex
) =
@_
;
my
@caller
=
caller
(0);
my
$ln
=
$caller
[2];
my
$fn
=
$caller
[1];
my
$ex
= $@;
confess
"expected error did not occur at $fn line $ln\n"
,
unless
$ex
;
if
(
$ex
!~ / at
$fn
line
$ln
\.?(?:$|\n)/s) {
confess
"Got UN-expected err (not ' at $fn line $ln'):\n«$ex»\n"
,
"\n"
;
}
if
(
$msg_regex
&&
$ex
!~
qr/$msg_regex/
) {
confess
"Got UN-expected err (not matching $msg_regex) at $fn line $ln'):\n«$ex»\n"
,
"\n"
;
}
verif_no_internals_mentioned(
$ex
);
dprint
"Got expected err: $ex\n"
;
}
sub
insert_loc_in_evalstr($) {
my
$orig
=
shift
;
my
(
$fn
,
$lno
) = (
caller
(0))[1,2];
"# line $lno \"$fn\"\n"
.
$orig
}
sub
timed_run(&$@) {
my
(
$code
,
$maxcpusecs
,
@codeargs
) =
@_
;
my
$getcpu
=
eval
{
do
{
() = (
&Time::HiRes::clock
());
\
&Time::HiRes::clock
;
}} //
sub
{
my
@t
=
times
;
$t
[0]+
$t
[1] };
dprint(
"Note: $@"
)
if
$@;
$@ =
""
;
my
$startclock
=
&$getcpu
();
my
(
@result
,
$result
);
if
(
wantarray
) {
@result
=
&$code
(
@codeargs
)}
else
{
$result
=
&$code
(
@codeargs
)};
my
$cpusecs
=
&$getcpu
() -
$startclock
;
confess
"TOOK TOO LONG ($cpusecs CPU seconds vs. limit of $maxcpusecs)\n"
if
$cpusecs
>
$maxcpusecs
;
if
(
wantarray
) {
return
@result
}
else
{
return
$result
};
}
1;