use Test::More;
use B 'svref_2object';
+BEGIN { $^P |= 0x210 }
# This is a mess. The stash can supposedly handle Unicode but the behavior
# is literally undefined before 5.16 (with crashes beyond the basic plane),
# and remains unclear past 5.16 with evalbytes and feature unicode_eval
# In any case - Sub::Name needs to *somehow* work with this, so we will do
# a heuristic with ambiguous eval and looking for octets in the stash
-use if $] >= 5.016, feature => 'unicode_eval';
+use if "$]" >= 5.016, feature => 'unicode_eval';
+
+if ("$]" >= 5.008) {
+ my $builder = Test::More->builder;
+ binmode $builder->output, ":encoding(utf8)";
+ binmode $builder->failure_output, ":encoding(utf8)";
+ binmode $builder->todo_output, ":encoding(utf8)";
+}
sub compile_named_sub {
my ( $fullname, $body ) = @_;
$expected =~ s/'/::/g;
# this is apparently how things worked before 5.16
- utf8::encode($expected) if $] < 5.016 and $ord > 255;
+ utf8::encode($expected) if "$]" < 5.016 and $ord > 255;
my $stash_name = join '::', map { $_->STASH->NAME, $_->NAME } svref_2object($sub)->GV;
is $stash_name, $expected, "stash name for $type is correct $for_what";
is $sub->(), $expected, "caller() in $type returns correct name $for_what";
+ ok $DB::sub{$expected}, "%DB::sub entry for $type is correct $for_what";
}
#######################################################################
# 5.14 is the first perl to start properly handling \0 in identifiers
unshift @ordinal, 0
- unless $] < 5.014;
+ unless "$]" < 5.014;
# Unicode in 5.6 is not sane (crashes etc)
push @ordinal,
0x498, # CYRILLIC CAPITAL LETTER ZE WITH DESCENDER
0x2122, # TRADE MARK SIGN
0x1f4a9, # PILE OF POO
- unless $] < 5.008;
+ unless "$]" < 5.008;
-plan tests => @ordinal * 2 * 2;
+plan tests => @ordinal * 2 * 3;
my $legal_ident_char = "A-Z_a-z0-9'";
$legal_ident_char .= join '', map chr, 0x100, 0x498
- unless $] < 5.008;
+ unless "$]" < 5.008;
+my $uniq = 'A000';
for my $ord (@ordinal) {
my $sub;
- my $pkg = sprintf 'test::SOME_%c_STASH', $ord;
- my $subname = sprintf 'SOME_%c_NAME', $ord;
+ $uniq++;
+ my $pkg = sprintf 'test::%s::SOME_%c_STASH', $uniq, $ord;
+ my $subname = sprintf 'SOME_%s_%c_NAME', $uniq, $ord;
my $fullname = join '::', $pkg, $subname;
$sub = subname $fullname => sub { (caller(0))[3] };
# test that we can *always* compile at least within the correct package
my $expected;
if ( chr($ord) =~ m/^[$legal_ident_char]$/o ) { # compile directly
- $expected = $fullname;
- $sub = compile_named_sub $fullname => '(caller(0))[3]';
+ $expected = "native::$fullname";
+ $sub = compile_named_sub $expected => '(caller(0))[3]';
}
else { # not a legal identifier but at least test the package name by aliasing
- $expected = "${pkg}::foo";
- { no strict 'refs'; *palatable:: = *{"${pkg}::"} } # now palatable:: literally means ${pkg}::
- $sub = compile_named_sub 'palatable::foo' => '(caller(0))[3]';
+ $expected = "aliased::native::$fullname";
+ {
+ no strict 'refs';
+ *palatable:: = *{"aliased::native::${pkg}::"};
+ # now palatable:: literally means aliased::native::${pkg}::
+ my $encoded_sub = $subname;
+ utf8::encode($encoded_sub) if "$]" < 5.016 and $ord > 255;
+ ${"palatable::$encoded_sub"} = 1;
+ ${"palatable::"}{"sub"} = ${"palatable::"}{$encoded_sub};
+ # and palatable::sub means aliased::native::${pkg}::${subname}
+ }
+ $sub = compile_named_sub 'palatable::sub' => '(caller(0))[3]';
}
caller3_ok $sub, $expected, 'natively compiled sub', $ord;
}