This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
op.c: Suppress compiler warning
[perl5.git] / op.c
diff --git a/op.c b/op.c
index fcc4760..fc0306a 100644 (file)
--- a/op.c
+++ b/op.c
@@ -548,9 +548,10 @@ S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP
 }
 
 STATIC void
 }
 
 STATIC void
-S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
+S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
 {
 {
-    PERL_ARGS_ASSERT_BAD_TYPE_SV;
+    SV * const namesv = gv_ename(gv);
+    PERL_ARGS_ASSERT_BAD_TYPE_GV;
  
     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
                 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
  
     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
                 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
@@ -6809,52 +6810,61 @@ void
 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
                    const STRLEN len, const U32 flags)
 {
 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
                    const STRLEN len, const U32 flags)
 {
-    const char * const cvp = SvROK(cv) ? "" : CvPROTO(cv);
-    const STRLEN clen = CvPROTOLEN(cv);
+    SV *name = NULL, *msg;
+    const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
+    STRLEN clen = CvPROTOLEN(cv), plen = len;
 
     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
 
 
     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
 
-    if (((!p != !cvp) /* One has prototype, one has not.  */
-       || (p && (
-                 (flags & SVf_UTF8) == SvUTF8(cv)
-                  ? len != clen || memNE(cvp, p, len)
-                  : flags & SVf_UTF8
-                     ? bytes_cmp_utf8((const U8 *)cvp, clen,
-                                      (const U8 *)p, len)
-                     : bytes_cmp_utf8((const U8 *)p, len,
-                                      (const U8 *)cvp, clen)
-                )
-          )
-        )
-        && ckWARN_d(WARN_PROTOTYPE)) {
-       SV* const msg = sv_newmortal();
-       SV* name = NULL;
+    if (p == NULL && cvp == NULL)
+       return;
 
 
-       if (gv)
-       {
-         if (isGV(gv))
-           gv_efullname3(name = sv_newmortal(), gv, NULL);
-         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
-           name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1,
-                                 SvUTF8(gv)|SVs_TEMP);
-         else name = (SV *)gv;
-       }
-       sv_setpvs(msg, "Prototype mismatch:");
-       if (name)
-           Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
-       if (cvp)
-           Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
-               SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
-           );
-       else
-           sv_catpvs(msg, ": none");
-       sv_catpvs(msg, " vs ");
-       if (p)
-           Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
-       else
-           sv_catpvs(msg, "none");
-       Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
+    if (!ckWARN_d(WARN_PROTOTYPE))
+       return;
+
+    if (p && cvp) {
+       p = S_strip_spaces(aTHX_ p, &plen);
+       cvp = S_strip_spaces(aTHX_ cvp, &clen);
+       if ((flags & SVf_UTF8) == SvUTF8(cv)) {
+           if (plen == clen && memEQ(cvp, p, plen))
+               return;
+       } else {
+           if (flags & SVf_UTF8) {
+               if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
+                   return;
+            }
+           else {
+               if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
+                   return;
+           }
+       }
     }
     }
+
+    msg = sv_newmortal();
+
+    if (gv)
+    {
+       if (isGV(gv))
+           gv_efullname3(name = sv_newmortal(), gv, NULL);
+       else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
+           name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
+       else name = (SV *)gv;
+    }
+    sv_setpvs(msg, "Prototype mismatch:");
+    if (name)
+       Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
+    if (cvp)
+       Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")", 
+           UTF8fARG(SvUTF8(cv),clen,cvp)
+       );
+    else
+       sv_catpvs(msg, ": none");
+    sv_catpvs(msg, " vs ");
+    if (p)
+       Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
+    else
+       sv_catpvs(msg, "none");
+    Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
 }
 
 static void const_sv_xsub(pTHX_ CV* cv);
 }
 
 static void const_sv_xsub(pTHX_ CV* cv);
@@ -9656,7 +9666,10 @@ Perl_ck_sort(pTHX_ OP *o)
 {
     dVAR;
     OP *firstkid;
 {
     dVAR;
     OP *firstkid;
-    HV * const hinthv = GvHV(PL_hintgv);
+    OP *kid;
+    HV * const hinthv =
+       PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
+    U8 stacked;
 
     PERL_ARGS_ASSERT_CK_SORT;
 
 
     PERL_ARGS_ASSERT_CK_SORT;
 
@@ -9674,7 +9687,7 @@ Perl_ck_sort(pTHX_ OP *o)
     if (o->op_flags & OPf_STACKED)
        simplify_sort(o);
     firstkid = cLISTOPo->op_first->op_sibling;         /* get past pushmark */
     if (o->op_flags & OPf_STACKED)
        simplify_sort(o);
     firstkid = cLISTOPo->op_first->op_sibling;         /* get past pushmark */
-    if (o->op_flags & OPf_STACKED) {                   /* may have been cleared */
+    if ((stacked = o->op_flags & OPf_STACKED)) {       /* may have been cleared */
        OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
 
        if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
        OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
 
        if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
@@ -9693,8 +9706,12 @@ Perl_ck_sort(pTHX_ OP *o)
        firstkid = firstkid->op_sibling;
     }
 
        firstkid = firstkid->op_sibling;
     }
 
-    /* provide list context for arguments */
-    list(firstkid);
+    for (kid = firstkid; kid; kid = kid->op_sibling) {
+       /* provide list context for arguments */
+       list(kid);
+       if (stacked)
+           op_lvalue(kid, OP_GREPSTART);
+    }
 
     return o;
 }
 
     return o;
 }
@@ -9712,8 +9729,6 @@ S_simplify_sort(pTHX_ OP *o)
 
     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
 
 
     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
 
-    if (!(o->op_flags & OPf_STACKED))
-       return;
     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
     kid = kUNOP->op_first;                             /* get past null */
     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
     kid = kUNOP->op_first;                             /* get past null */
@@ -10079,6 +10094,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
     if (SvTYPE(protosv) == SVt_PVCV)
         proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
     else proto = SvPV(protosv, proto_len);
     if (SvTYPE(protosv) == SVt_PVCV)
         proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
     else proto = SvPV(protosv, proto_len);
+    proto = S_strip_spaces(aTHX_ proto, &proto_len);
     proto_end = proto + proto_len;
     aop = cUNOPx(entersubop)->op_first;
     if (!aop->op_sibling)
     proto_end = proto + proto_len;
     aop = cUNOPx(entersubop)->op_first;
     if (!aop->op_sibling)
@@ -10123,9 +10139,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                proto++;
                arg++;
                if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
                proto++;
                arg++;
                if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
-                   bad_type_sv(arg,
+                   bad_type_gv(arg,
                            arg == 1 ? "block or sub {}" : "sub {}",
                            arg == 1 ? "block or sub {}" : "sub {}",
-                           gv_ename(namegv), 0, o3);
+                           namegv, 0, o3);
                break;
            case '*':
                /* '*' allows any scalar type, including bareword */
                break;
            case '*':
                /* '*' allows any scalar type, including bareword */
@@ -10210,9 +10226,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                                     OP_READ, /* not entersub */
                                     OP_LVALUE_NO_CROAK
                                    )) goto wrapref;
                                     OP_READ, /* not entersub */
                                     OP_LVALUE_NO_CROAK
                                    )) goto wrapref;
-                           bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
+                           bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
                                        (int)(end - p), p),
                                        (int)(end - p), p),
-                                   gv_ename(namegv), 0, o3);
+                                   namegv, 0, o3);
                        } else
                            goto oops;
                        break;
                        } else
                            goto oops;
                        break;
@@ -10220,13 +10236,13 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                        if (o3->op_type == OP_RV2GV)
                            goto wrapref;
                        if (!contextclass)
                        if (o3->op_type == OP_RV2GV)
                            goto wrapref;
                        if (!contextclass)
-                           bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
+                           bad_type_gv(arg, "symbol", namegv, 0, o3);
                        break;
                    case '&':
                        if (o3->op_type == OP_ENTERSUB)
                            goto wrapref;
                        if (!contextclass)
                        break;
                    case '&':
                        if (o3->op_type == OP_ENTERSUB)
                            goto wrapref;
                        if (!contextclass)
-                           bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
+                           bad_type_gv(arg, "subroutine entry", namegv, 0,
                                    o3);
                        break;
                    case '$':
                                    o3);
                        break;
                    case '$':
@@ -10242,7 +10258,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                                    OP_READ,  /* not entersub */
                                    OP_LVALUE_NO_CROAK
                               )) goto wrapref;
                                    OP_READ,  /* not entersub */
                                    OP_LVALUE_NO_CROAK
                               )) goto wrapref;
-                           bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
+                           bad_type_gv(arg, "scalar", namegv, 0, o3);
                        }
                        break;
                    case '@':
                        }
                        break;
                    case '@':
@@ -10250,14 +10266,14 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                                o3->op_type == OP_PADAV)
                            goto wrapref;
                        if (!contextclass)
                                o3->op_type == OP_PADAV)
                            goto wrapref;
                        if (!contextclass)
-                           bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
+                           bad_type_gv(arg, "array", namegv, 0, o3);
                        break;
                    case '%':
                        if (o3->op_type == OP_RV2HV ||
                                o3->op_type == OP_PADHV)
                            goto wrapref;
                        if (!contextclass)
                        break;
                    case '%':
                        if (o3->op_type == OP_RV2HV ||
                                o3->op_type == OP_PADHV)
                            goto wrapref;
                        if (!contextclass)
-                           bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
+                           bad_type_gv(arg, "hash", namegv, 0, o3);
                        break;
                    wrapref:
                        {
                        break;
                    wrapref:
                        {
@@ -10735,9 +10751,11 @@ Perl_ck_length(pTHX_ OP *o)
                     name, hash ? "keys " : "", name
                 );
             else if (hash)
                     name, hash ? "keys " : "", name
                 );
             else if (hash)
+     /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
             else
                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
             else
+     /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
                     "length() used on @array (did you mean \"scalar(@array)\"?)");
         }
                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
                     "length() used on @array (did you mean \"scalar(@array)\"?)");
         }
@@ -11962,14 +11980,7 @@ const_sv_xsub(pTHX_ CV* cv)
     dVAR;
     dXSARGS;
     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
     dVAR;
     dXSARGS;
     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
-    if (items != 0) {
-       NOOP;
-#if 0
-       /* diag_listed_as: SKIPME */
-        Perl_croak(aTHX_ "usage: %s::%s()",
-                   HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
-#endif
-    }
+    PERL_UNUSED_ARG(items);
     if (!sv) {
        XSRETURN(0);
     }
     if (!sv) {
        XSRETURN(0);
     }
Unnamed repository; edit this file 'description' to name the repository.