diff --git a/MANIFEST b/MANIFEST index e2a79c070f69..70477450ff7d 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4755,6 +4755,7 @@ ext/B/Makefile.PL Compiler backend makefile writer ext/B/O.pm Compiler front-end module (-MO=...) ext/B/t/b.t See if B works ext/B/t/B/success.pm Test module for ext/B/t/o.t +ext/B/t/b_uni.t See if B works with Unicode ext/B/t/bool.t See if B works for bool ext/B/t/concise.t See whether B::Concise works ext/B/t/concise-xs.t See whether B::Concise recognizes XS functions diff --git a/ext/B/B.pm b/ext/B/B.pm index 5464549d4f83..7d6a8472a7c3 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -20,7 +20,7 @@ sub import { # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.90'; + $B::VERSION = '1.91'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. diff --git a/ext/B/B.xs b/ext/B/B.xs index 2d649ccb2440..efc1dec2184b 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -1033,11 +1033,21 @@ next(o) - (char*)tbl, SVs_TEMP); } - else - ret = newSVpvn_flags(cPVOPo->op_pv, strlen(cPVOPo->op_pv), SVs_TEMP); + else { + U32 label_utf8 = (cPVOPo->op_private & OPpPV_IS_UTF8) + ? SVf_UTF8 : 0; + + ret = newSVpvn_flags(cPVOPo->op_pv, strlen(cPVOPo->op_pv), + SVs_TEMP | label_utf8); + } break; case 42: /* B::COP::label */ - ret = sv_2mortal(newSVpv(CopLABEL(cCOPo),0)); + { + STRLEN len; + U32 flags; + const char *pv = CopLABEL_len_flags(cCOPo, &len, &flags); + ret = newSVpvn_flags(pv, len, SVs_TEMP | (flags & SVf_UTF8)); + } break; case 43: /* B::COP::arybase */ ret = sv_2mortal(newSVuv(0)); diff --git a/ext/B/t/b_uni.t b/ext/B/t/b_uni.t new file mode 100644 index 000000000000..1a75a96d7434 --- /dev/null +++ b/ext/B/t/b_uni.t @@ -0,0 +1,56 @@ +#!./perl + +BEGIN { + unshift @INC, 't'; + require Config; + if (($Config::Config{'extensions'} !~ /\bB\b/) ){ + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } +} + +$| = 1; +use warnings; +use strict; +use utf8; +use B; +BEGIN { + eval { require threads; threads->import; } +} +use Test::More; + +sub f { + # I like pi + π:1; +} + +{ + # github 24040 + my $f = B::svref_2object(\&f); + my $op = $f->START; + while ($op && !($op->name =~ /^(db|next)state$/ && $op->label)) { + $op = $op->next; + } + $op or die "Not found"; + my $label = $op->label; + is($label, "π", "UTF8 label correctly UTF8"); +} + +sub f2 { + goto π; + π:1; +} + +{ + # github 24040 - goto + my $f2 = B::svref_2object(\&f2); + my $op = $f2->START; + while ($op && $op->name ne 'goto') { + $op = $op->next; + } + $op or die "goto Not found"; + my $label = $op->pv; + is($label, "π", "goto UTF8 label correctly UTF8"); +} + +done_testing(); diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 70251b600cdb..68d87a5c204c 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -125,6 +125,15 @@ XXX Remove this section if F did not add any cont =item * +L has been upgraded from version 1.90 to 1.91. + +B::COP::label now marks the returned string as UTF-8 if needed. [GH +#24040] + +B::PVOP::pv now marks the returned string as UTF-8 if needed. + +=item * + L has been upgraded from version 1.009 to 1.010. Send the function header generated by the C<-stash> option to the