In perl.git, the branch sprout/utf8sym4 has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/43fe3ecfe75da2dd8346dbb206e7e2193a988a12?hp=88461536b3052da4608362a4006784ca1c75c8ab>
- Log -----------------------------------------------------------------
commit 43fe3ecfe75da2dd8346dbb206e7e2193a988a12
Author: Brian Fraser <frase...@gmail.com>
Date: Wed Jul 6 13:45:07 2011 -0300
pp_hot.c: Make warnings utf8-clean
M pp_hot.c
M t/lib/strict/refs
M t/uni/method.t
commit 348921cfc95de014a716703180ea6875ead33063
Author: Father Chrysostomos <spr...@cpan.org>
Date: Wed Oct 5 13:33:36 2011 -0700
Teach porting/diag.t about SVf32 and SVf256
M t/porting/diag.t
commit 1c66b29de76825bbd183304979c16471ede7825c
Author: Brian Fraser <frase...@gmail.com>
Date: Wed Jul 6 13:08:37 2011 -0300
pp.c: Make warnings utf8-clean
M pp.c
M t/lib/warnings/pp
commit 237a75b22ecb1cb2786e273ee0320d72429f8f71
Author: Brian Fraser <frase...@gmail.com>
Date: Wed Jul 6 12:50:59 2011 -0300
Make op.c warnings UTF8-clean
M op.c
M sv.c
M t/lib/strict/subs
M t/lib/strict/vars
M t/lib/warnings/gv
M t/lib/warnings/op
commit 96791514679248abff0585b6ae2a20a0f860eb10
Author: Brian Fraser <frase...@gmail.com>
Date: Wed Oct 5 12:48:07 2011 -0700
Make gv.c and pp_ctl.c warnings utf8-clean
M gv.c
M pp_ctl.c
-----------------------------------------------------------------------
Summary of changes:
gv.c | 39 ++++++++++++--------
op.c | 11 ++++--
pp.c | 8 +++--
pp_ctl.c | 42 ++++++++++++---------
pp_hot.c | 10 +++---
sv.c | 8 ++--
t/lib/strict/refs | 8 ++++
t/lib/strict/subs | 9 +++++
t/lib/strict/vars | 90 +++++++++++++++++++++++++++++++++++++++++++++++
t/lib/warnings/gv | 22 +++++++++++-
t/lib/warnings/op | 101 +++++++++++++++++++++++++++++++++++++++++++++++++++++
t/lib/warnings/pp | 12 ++++++
t/porting/diag.t | 5 ++-
t/uni/method.t | 4 ++-
14 files changed, 317 insertions(+), 52 deletions(-)
diff --git a/gv.c b/gv.c
index 52846fa..2311c19 100644
--- a/gv.c
+++ b/gv.c
@@ -715,8 +715,10 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name,
STRLEN len, I32 level,
cstash = gv_stashsv(linear_sv, 0);
if (!cstash) {
- Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package
%"SVf" for @%s::ISA",
- SVfARG(linear_sv), hvname);
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Can't locate package %"SVf" for @%"SVf"::ISA",
+ SVfARG(linear_sv),
+ SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))));
continue;
}
@@ -1155,8 +1157,9 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name,
STRLEN len, U32 flags)
&& (GvCVGEN(gv) || GvSTASH(gv) != stash)
)
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Use of inherited AUTOLOAD for non-method %s::%.*s()
is deprecated",
- SvPV_nolen(packname), (int)len, name);
+ "Use of inherited AUTOLOAD for non-method
%"SVf"::%"SVf"() is deprecated",
+ SVfARG(packname),
+ SVfARG(newSVpvn_flags(name, len, SVs_TEMP |
is_utf8)));
if (CvISXSUB(cv)) {
/* rather than lookup/init $AUTOLOAD here
@@ -1403,7 +1406,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN
full_len, I32 flags,
goto no_stash;
}
- if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
+ if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) {
/* accidental stringify on a GV? */
name++;
}
@@ -1542,17 +1545,18 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN
full_len, I32 flags,
(sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
(sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
{
+ SV* namesv = newSVpvn_flags(name, len, SVs_TEMP |
is_utf8);
/* diag_listed_as: Variable "%s" is not imported%s */
Perl_ck_warner_d(
aTHX_ packWARN(WARN_MISC),
- "Variable \"%c%s\" is not imported",
+ "Variable \"%c%"SVf"\" is not imported",
sv_type == SVt_PVAV ? '@' :
sv_type == SVt_PVHV ? '%' : '$',
- name);
+ SVfARG(namesv));
if (GvCVu(*gvp))
Perl_ck_warner_d(
aTHX_ packWARN(WARN_MISC),
- "\t(Did you mean &%s instead?)\n", name
+ "\t(Did you mean &%"SVf" instead?)\n",
SVfARG(namesv)
);
stash = NULL;
}
@@ -1570,11 +1574,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN
full_len, I32 flags,
if (!stash) {
if (add) {
SV * const err = Perl_mess(aTHX_
- "Global symbol \"%s%s\" requires explicit package name",
+ "Global symbol \"%s%"SVf"\" requires explicit package name",
(sv_type == SVt_PV ? "$"
: sv_type == SVt_PVAV ? "@"
: sv_type == SVt_PVHV ? "%"
- : ""), name);
+ : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
GV *gv;
if (USE_UTF8_IN_NAMES)
SvUTF8_on(err);
@@ -1637,11 +1641,12 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN
full_len, I32 flags,
faking_it = SvOK(gv);
if (add & GV_ADDWARN)
- Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s
unexpectedly", nambeg);
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf"
unexpectedly",
+ SVfARG(newSVpvn_flags(nambeg, name_cursor-nambeg, SVs_TEMP |
is_utf8 )));
gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
- if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
- : (PL_dowarn & G_WARN_ON ) ) )
+ if ( isIDFIRST_lazy_if(name, is_utf8)
+ && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn &
G_WARN_ON ) ) )
GvMULTI_on(gv) ;
/* set up magic where warranted */
@@ -2023,7 +2028,8 @@ Perl_gv_check(pTHX_ const HV *stash)
if (hv != PL_defstash && hv != stash)
gv_check(hv); /* nested package */
}
- else if (isALPHA(*HeKEY(entry))) {
+ else if ( *HeKEY(entry) != '_'
+ && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
const char *file;
gv = MUTABLE_GV(HeVAL(entry));
if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
@@ -2037,8 +2043,9 @@ Perl_gv_check(pTHX_ const HV *stash)
= gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
#endif
Perl_warner(aTHX_ packWARN(WARN_ONCE),
- "Name \"%s::%s\" used only once: possible typo",
- HvNAME_get(stash), GvNAME(gv));
+ "Name \"%"SVf"::%"SVf"\" used only once: possible typo",
+ SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))),
+ SVfARG(sv_2mortal(newSVhek(GvNAME_HEK(gv)))));
}
}
}
diff --git a/op.c b/op.c
index f5654cd..49c1513 100644
--- a/op.c
+++ b/op.c
@@ -987,6 +987,7 @@ Perl_scalarvoid(pTHX_ OP *o)
dVAR;
OP *kid;
const char* useless = NULL;
+ U32 useless_is_utf8 = 0;
SV* sv;
U8 want;
@@ -1167,6 +1168,7 @@ Perl_scalarvoid(pTHX_ OP *o)
SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
"a constant (%"SVf")", sv));
useless = SvPV_nolen(msv);
+ useless_is_utf8 = SvUTF8(msv);
}
else
useless = "a constant (undef)";
@@ -1316,7 +1318,9 @@ Perl_scalarvoid(pTHX_ OP *o)
return scalar(o);
}
if (useless)
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void
context", useless);
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in
void context",
+ newSVpvn_flags(useless, strlen(useless),
+ SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
return o;
}
@@ -6542,8 +6546,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
if (PL_parser && PL_parser->copline != NOLINE)
CopLINE_set(PL_curcop, PL_parser->copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- CvCONST(cv) ? "Constant subroutine %s redefined"
- : "Subroutine %s redefined", name);
+ CvCONST(cv) ? "Constant subroutine %"SVf" redefined"
+ : "Subroutine %"SVf" redefined",
+ SVfARG(cSVOPo->op_sv));
CopLINE_set(PL_curcop, oldline);
}
#ifdef PERL_MAD
diff --git a/pp.c b/pp.c
index a102a21..3590bd9 100644
--- a/pp.c
+++ b/pp.c
@@ -980,9 +980,11 @@ PP(pp_undef)
break;
case SVt_PVCV:
if (cv_const_sv((const CV *)sv))
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s
undefined",
- CvANON((const CV *)sv) ? "(anonymous)"
- : GvENAME(CvGV((const CV *)sv)));
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Constant subroutine %"SVf" undefined",
+ SVfARG(CvANON((const CV *)sv)
+ ? newSVpvs_flags("(anonymous)", SVs_TEMP)
+ : sv_2mortal(newSVhek(GvENAME_HEK(CvGV((const CV
*)sv))))));
/* FALLTHROUGH */
case SVt_PVFM:
{
diff --git a/pp_ctl.c b/pp_ctl.c
index 2d8c4f2..d35462c 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1657,8 +1657,8 @@ Perl_qerror(pTHX_ SV *err)
if (PL_in_eval) {
if (PL_in_eval & EVAL_KEEPERR) {
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
- SvPV_nolen_const(err));
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
+ SVfARG(err));
}
else
sv_catsv(ERRSV, err);
@@ -1763,20 +1763,21 @@ Perl_die_unwind(pTHX_ SV *msv)
PL_curcop = oldcop;
if (optype == OP_REQUIRE) {
- const char* const msg = SvPVx_nolen_const(exceptsv);
(void)hv_store(GvHVn(PL_incgv),
- SvPVX_const(namesv), SvCUR(namesv),
+ SvPVX_const(namesv),
+ SvUTF8(namesv) ? -SvCUR(namesv) : SvCUR(namesv),
&PL_sv_undef, 0);
/* note that unlike pp_entereval, pp_require isn't
* supposed to trap errors. So now that we've popped the
* EVAL that pp_require pushed, and processed the error
* message, rethrow the error */
- Perl_croak(aTHX_ "%sCompilation failed in require",
- *msg ? msg : "Unknown error\n");
+ Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
+ SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown
error\n",
+
SVs_TEMP)));
}
if (in_eval & EVAL_KEEPERR) {
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
- SvPV_nolen_const(exceptsv));
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
+ SVfARG(exceptsv));
}
else {
sv_setsv(ERRSV, exceptsv);
@@ -2478,7 +2479,8 @@ PP(pp_return)
{
/* Unassume the success we assumed earlier. */
(void)hv_delete(GvHVn(PL_incgv),
- SvPVX_const(namesv), SvCUR(namesv),
+ SvPVX_const(namesv),
+ SvUTF8(namesv) ? -SvCUR(namesv) : SvCUR(namesv),
G_DISCARD);
DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
}
@@ -3530,7 +3532,6 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32
seq)
PERL_CONTEXT *cx;
I32 optype; /* Used by POPEVAL. */
SV *namesv;
- const char *msg;
cx = NULL;
namesv = NULL;
@@ -3555,7 +3556,6 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32
seq)
if (yystatus != 3)
LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
- msg = SvPVx_nolen_const(ERRSV);
if (in_require) {
if (!cx) {
/* If cx is still NULL, it means that we didn't go in the
@@ -3565,21 +3565,26 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside,
U32 seq)
namesv = cx->blk_eval.old_namesv;
}
(void)hv_store(GvHVn(PL_incgv),
- SvPVX_const(namesv), SvCUR(namesv),
+ SvPVX_const(namesv),
+ SvUTF8(namesv) ? -SvCUR(namesv) : SvCUR(namesv),
&PL_sv_undef, 0);
- Perl_croak(aTHX_ "%sCompilation failed in require",
- *msg ? msg : "Unknown error\n");
+ Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
+ SVfARG(ERRSV
+ ? ERRSV
+ : newSVpvs_flags("Unknown error\n",
SVs_TEMP)));
}
else if (startop) {
if (yystatus != 3) {
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
}
- Perl_croak(aTHX_ "%sCompilation failed in regexp",
- (*msg ? msg : "Unknown error\n"));
+ Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp",
+ SVfARG(ERRSV
+ ? ERRSV
+ : newSVpvs_flags("Unknown error\n",
SVs_TEMP)));
}
else {
- if (!*msg) {
+ if (!*(SvPVx_nolen_const(ERRSV))) {
sv_setpvs(ERRSV, "Compilation error");
}
}
@@ -4270,7 +4275,8 @@ PP(pp_leaveeval)
{
/* Unassume the success we assumed earlier. */
(void)hv_delete(GvHVn(PL_incgv),
- SvPVX_const(namesv), SvCUR(namesv),
+ SvPVX_const(namesv),
+ SvUTF8(namesv) ? -SvCUR(namesv) : SvCUR(namesv),
G_DISCARD);
retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
SVfARG(namesv));
diff --git a/pp_hot.c b/pp_hot.c
index 5926874..aaff28f 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2587,7 +2587,7 @@ PP(pp_entersub)
if (!sym)
DIE(aTHX_ PL_no_usym, "a subroutine");
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref
while \"strict refs\" in use", sym, len>32 ? "..." : "");
+ DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine
ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
break;
}
@@ -3006,10 +3006,10 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
&& (ob = MUTABLE_SV(GvIO((const GV *)ob)))
&& SvOBJECT(ob))))
{
- const char * const name = SvPV_nolen_const(meth);
- Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
- (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
- name);
+ Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
+ SVfARG((SvSCREAM(meth) &&
strEQ(SvPV_nolen_const(meth),"isa"))
+ ? newSVpvs_flags("DOES", SVs_TEMP)
+ : meth));
}
stash = SvSTASH(ob);
diff --git a/sv.c b/sv.c
index b736369..1a24aca 100644
--- a/sv.c
+++ b/sv.c
@@ -3846,10 +3846,10 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
(const char *)
(CvCONST(cv)
- ? "Constant subroutine %s::%s
redefined"
- : "Subroutine %s::%s redefined"),
- HvNAME_get(GvSTASH((const GV *)dstr)),
- GvENAME(MUTABLE_GV(dstr)));
+ ? "Constant subroutine %"SVf"::%"SVf"
redefined"
+ : "Subroutine %"SVf"::%"SVf"
redefined"),
+ SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(GvSTASH((const GV
*)dstr))))),
+ SVfARG(sv_2mortal(newSVhek(GvENAME_HEK(MUTABLE_GV(dstr))))));
}
}
if (!intro)
diff --git a/t/lib/strict/refs b/t/lib/strict/refs
index 36b36f1..09b962f 100644
--- a/t/lib/strict/refs
+++ b/t/lib/strict/refs
@@ -338,3 +338,11 @@ use strict 'refs';
my $o = 1 ; $o->{1} ;
EXPECT
Can't use string ("1") as a HASH ref while "strict refs" in use at - line 3.
+########
+# pp_hot.c [pp_entersub]
+use strict 'refs';
+use utf8;
+use open qw( :utf8 :std );
+&{"Ｆ"};
+EXPECT
+Can't use string ("Ｆ") as a subroutine ref while "strict refs" in use at -
line 5.
diff --git a/t/lib/strict/subs b/t/lib/strict/subs
index 84bf874..57327cc 100644
--- a/t/lib/strict/subs
+++ b/t/lib/strict/subs
@@ -381,6 +381,15 @@ EXPECT
Bareword "foo" not allowed while "strict subs" in use at (re_eval 1) line 1.
Compilation failed in regexp at - line 3.
########
+# Regexp compilation errors weren't UTF-8 clean
+use strict 'subs';
+use utf8;
+use open qw( :utf8 :std );
+qr/(?{my $x=fòò})/;
+EXPECT
+Bareword "fòò" not allowed while "strict subs" in use at (re_eval 1) line 1.
+Compilation failed in regexp at - line 5.
+########
# [perl #27628] strict 'subs' didn't warn on bareword array index
use strict 'subs';
my $x=$a[FOO];
diff --git a/t/lib/strict/vars b/t/lib/strict/vars
index 804d7ec..d41aa3c 100644
--- a/t/lib/strict/vars
+++ b/t/lib/strict/vars
@@ -83,6 +83,21 @@ Execution of - aborted due to compilation errors.
########
# Check compile time scope of strict vars pragma
+use strict 'vars' ;
+use utf8;
+use open qw( :utf8 :std );
+{
+ no strict ;
+ $jòè = 1 ;
+}
+$jòè = 1 ;
+EXPECT
+Variable "$jòè" is not imported at - line 10.
+Global symbol "$jòè" requires explicit package name at - line 10.
+Execution of - aborted due to compilation errors.
+########
+
+# Check compile time scope of strict vars pragma
no strict;
{
use strict 'vars' ;
@@ -127,6 +142,23 @@ Global symbol "$joe" requires explicit package name at
./abc line 2.
Compilation failed in require at - line 2.
########
+--FILE-- abc
+use strict 'vars' ;
+use utf8;
+use open qw( :utf8 :std );
+$jòè = 1 ;
+1;
+--FILE--
+use utf8;
+use open qw( :utf8 :std );
+$jòè = 1 ;
+require "./abc";
+EXPECT
+Variable "$jòè" is not imported at ./abc line 4.
+Global symbol "$jòè" requires explicit package name at ./abc line 4.
+Compilation failed in require at - line 4.
+########
+
--FILE-- abc.pm
use strict 'vars' ;
$joe = 1 ;
@@ -142,6 +174,24 @@ BEGIN failed--compilation aborted at - line 2.
########
--FILE-- abc.pm
+use strict 'vars' ;
+use utf8;
+use open qw( :utf8 :std );
+$jòè = 1 ;
+1;
+--FILE--
+use utf8;
+use open qw( :utf8 :std );
+$jòè = 1 ;
+use abc;
+EXPECT
+Variable "$jòè" is not imported at abc.pm line 4.
+Global symbol "$jòè" requires explicit package name at abc.pm line 4.
+Compilation failed in require at - line 4.
+BEGIN failed--compilation aborted at - line 4.
+########
+
+--FILE-- abc.pm
package Burp;
use strict;
$a = 1;$f = 1;$k = 1; # just to get beyond the limit...
@@ -225,6 +275,22 @@ Execution of - aborted due to compilation errors.
########
# Check scope of pragma with eval
+use strict 'vars' ;
+use utf8;
+use open qw( :utf8 :std );
+eval {
+ no strict ;
+ $jòè = 1 ;
+};
+print STDERR $@;
+$jòè = 1 ;
+EXPECT
+Variable "$jòè" is not imported at - line 11.
+Global symbol "$jòè" requires explicit package name at - line 11.
+Execution of - aborted due to compilation errors.
+########
+
+# Check scope of pragma with eval
no strict ;
eval '
$joe = 1 ;
@@ -337,6 +403,21 @@ Global symbol "$fred" requires explicit package name at -
line 8.
Execution of - aborted due to compilation errors.
########
+# strict vars with elapsed our - error
+use strict 'vars' ;
+use utf8;
+use open qw( :utf8 :std );
+sub fòò {
+ our $frèd;
+ $frèd;
+}
+$frèd ;
+EXPECT
+Variable "$frèd" is not imported at - line 10.
+Global symbol "$frèd" requires explicit package name at - line 10.
+Execution of - aborted due to compilation errors.
+########
+
# nested our with local - no error
$fred = 1;
use strict 'vars';
@@ -440,6 +521,15 @@ EXPECT
Global symbol "$foo" requires explicit package name at (re_eval 1) line 1.
Compilation failed in regexp at - line 3.
########
+# Regex compilation errors weren't UTF-8 clean.
+use strict 'vars';
+use utf8;
+use open qw( :utf8 :std );
+qr/(?{$fòò++})/;
+EXPECT
+Global symbol "$fòò" requires explicit package name at (re_eval 1) line 1.
+Compilation failed in regexp at - line 5.
+########
# [perl #73712] 'Variable is not imported' should be suppressible
$dweck;
use strict 'vars';
diff --git a/t/lib/warnings/gv b/t/lib/warnings/gv
index 42565f2..6101f69 100644
--- a/t/lib/warnings/gv
+++ b/t/lib/warnings/gv
@@ -17,7 +17,7 @@
Mandatory Warnings ALL TODO
------------------
- Had to create %s unexpectedly [gv_fetchpv]
+ Had to create %SVf unexpectedly [gv_fetchpv]
Attempt to free unreferenced glob pointers [gp_free]
__END__
@@ -43,6 +43,16 @@ EXPECT
Use of inherited AUTOLOAD for non-method main::fred() is deprecated at - line
5.
########
# gv.c
+use utf8;
+use open qw( :utf8 :std );
+sub OáÊ::AUTOLOAD { 1 } sub OáÊ::fáÆ {}
+@ISA = qw(OáÊ) ;
+use warnings 'deprecated' ;
+fáÆ() ;
+EXPECT
+Use of inherited AUTOLOAD for non-method main::fáÆ() is deprecated at -
line 7.
+########
+# gv.c
$a = ${"#"};
$a = ${"*"};
no warnings 'deprecated' ;
@@ -51,3 +61,13 @@ $a = ${"*"};
EXPECT
$# is no longer supported at - line 2.
$* is no longer supported at - line 3.
+########
+# gv.c
+use warnings 'syntax' ;
+use utf8;
+use open qw( :utf8 :std );
+package ï¼¹;
+@ISA = qw(Fred); joe()
+EXPECT
+Can't locate package Fred for @ï¼¹::ISA at - line 6.
+Undefined subroutine &ï¼¹::joe called at - line 6.
diff --git a/t/lib/warnings/op b/t/lib/warnings/op
index a687686..12c38b9 100644
--- a/t/lib/warnings/op
+++ b/t/lib/warnings/op
@@ -533,6 +533,26 @@ Useless use of a constant (4) in void context at - line 6.
Useless use of a constant (undef) in void context at - line 8.
########
# op.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'void' ;
+"à á¸c"; # OP_CONST
+"áº" . "Æ´"; # optimized to OP_CONST
+ＦＯＯ; # Bareword optimized to OP_CONST
+use constant ů => undef;
+ů;
+5 || print "bad\n"; # test OPpCONST_SHORTCIRCUIT
+print "boo\n" if ů; # test OPpCONST_SHORTCIRCUIT
+no warnings 'void' ;
+"à á¸c"; # OP_CONST
+"áº" . "Æ´"; # optimized to OP_CONST
+EXPECT
+Useless use of a constant (à á¸c) in void context at - line 5.
+Useless use of a constant (áºÆ´) in void context at - line 6.
+Useless use of a constant (ＦＯＯ) in void context at - line 7.
+Useless use of a constant (undef) in void context at - line 9.
+########
+# op.c
#
use warnings 'misc' ;
my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;my $d = 'test';
@@ -1071,3 +1091,84 @@ $x = split /y/, "z";
split /y/, "z";
EXPECT
Useless use of split in void context at - line 5.
+########
+# op.c
+use warnings 'redefine' ;
+use utf8;
+use open qw( :utf8 :std );
+sub frèd {}
+sub frèd {}
+no warnings 'redefine' ;
+sub frèd {}
+EXPECT
+Subroutine frèd redefined at - line 6.
+########
+# op.c
+use warnings 'redefine' ;
+use utf8;
+use open qw( :utf8 :std );
+sub frèd () { 1 }
+sub frèd () { 1 }
+no warnings 'redefine' ;
+sub frèd () { 1 }
+EXPECT
+Constant subroutine frèd redefined at - line 6.
+########
+# op.c
+no warnings 'redefine' ;
+use utf8;
+use open qw( :utf8 :std );
+sub frèd () { 1 }
+sub frèd () { 2 }
+EXPECT
+Constant subroutine frèd redefined at - line 6.
+########
+# op.c
+no warnings 'redefine' ;
+use utf8;
+use open qw( :utf8 :std );
+sub frèd () { 1 }
+*frèd = sub () { 2 };
+EXPECT
+Constant subroutine main::frèd redefined at - line 6.
+########
+# op.c
+use warnings 'redefine' ;
+use utf8;
+use open qw( :utf8 :std );
+sub á áÆ {}
+sub á áÆ {}
+no warnings 'redefine' ;
+sub á áÆ {}
+EXPECT
+Subroutine á áÆ redefined at - line 6.
+########
+# op.c
+use warnings 'redefine' ;
+use utf8;
+use open qw( :utf8 :std );
+sub á áÆ () { 1 }
+sub á áÆ () { 1 }
+no warnings 'redefine' ;
+sub á áÆ () { 1 }
+EXPECT
+Constant subroutine á áÆ redefined at - line 6.
+########
+# op.c
+no warnings 'redefine' ;
+use utf8;
+use open qw( :utf8 :std );
+sub á áÆ () { 1 }
+sub á áÆ () { 2 }
+EXPECT
+Constant subroutine á áÆ redefined at - line 6.
+########
+# op.c
+no warnings 'redefine' ;
+use utf8;
+use open qw( :utf8 :std );
+sub á áÆ () { 1 }
+*á áÆ = sub () { 2 };
+EXPECT
+Constant subroutine main::á áÆ redefined at - line 6.
+########
diff --git a/t/lib/warnings/pp b/t/lib/warnings/pp
index e6b3802..89ebcbc 100644
--- a/t/lib/warnings/pp
+++ b/t/lib/warnings/pp
@@ -96,6 +96,18 @@ EXPECT
Constant subroutine foo undefined at - line 4.
########
# pp.c
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'misc';
+sub à¸á¶± () { 1 }
+undef &à¸á¶±;
+no warnings 'misc';
+sub Æ () { 2 }
+undef &Æ;
+EXPECT
+Constant subroutine à¸á¶± undefined at - line 6.
+########
+# pp.c
use warnings 'misc';
$foo = sub () { 3 };
undef &$foo;
diff --git a/t/porting/diag.t b/t/porting/diag.t
index 0a81b29..cd09098 100644
--- a/t/porting/diag.t
+++ b/t/porting/diag.t
@@ -142,6 +142,8 @@ my %specialformats = (IVdf => 'd',
NVef => 'f',
NVff => 'f',
NVgf => 'f',
+ SVf256=>'s',
+ SVf32=> 's',
SVf => 's');
my $format_modifiers = qr/ [#0\ +-]* # optional flags
(?: [1-9][0-9]* | \* )? # optional field width
@@ -149,7 +151,8 @@ my $format_modifiers = qr/ [#0\ +-]* #
optional flags
(?: h|l )? # optional length modifier
/x;
-my $specialformats = join '|', sort keys %specialformats;
+my $specialformats =
+ join '|', sort { length $b cmp length $a } keys %specialformats;
my $specialformats_re = qr/%$format_modifiers"\s*($specialformats)(\s*")?/;
# Recursively descend looking for source files.
diff --git a/t/uni/method.t b/t/uni/method.t
index fdefbf5..5009a1c 100644
--- a/t/uni/method.t
+++ b/t/uni/method.t
@@ -15,7 +15,7 @@ use utf8;
use open qw( :utf8 :std );
no warnings 'once';
-plan(tests => 15);
+plan(tests => 16);
#Can't use bless yet, as it might not be clean
@@ -38,3 +38,5 @@ is(Ｆ->${\"ï½"}, "UTF8 Stash&meth", '..as does for
->${\""}');
eval { Ｆ->${\"ï½\0nul"} };
ok $@, "Even if both stash and method are in UTF-8, lookup is nul-clean";
+eval { my $ref = \my $var; $ref->ï½ï½
ï½ï½ï½ï½ };
+like $@, qr/Can't call method "ï½ï½
ï½ï½ï½ï½" on unblessed reference /u;
--
Perl5 Master Repository
