Call get-magic before rejecting non-refs in sv_bless

[perl5.git] / pp_sys.c

diff --git a/pp_sys.c b/pp_sys.c
index 06b3684..b837a1e 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -367,7 +367,7 @@ PP(pp_glob)
      * is called once and only once */
     if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
 
-    tryAMAGICunTARGETlist(iter_amg, 0, (PL_op->op_flags & OPf_SPECIAL));
+    tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
 
     if (PL_op->op_flags & OPf_SPECIAL) {
        /* call Perl-level glob function instead. Stack args are:
@@ -376,11 +376,7 @@ PP(pp_glob)
         * */
        return NORMAL;
     }
-    /* stack args are: wildcard, gv(_GEN_n) */
-
     if (PL_globhook) {
-       PUSHs(GvSV(gv));
-       PUTBACK;
        PL_globhook(aTHX);
        return NORMAL;
     }
@@ -497,6 +493,7 @@ PP(pp_die)
     }
     else {
        SV * const errsv = ERRSV;
+       SvGETMAGIC(errsv);
        if (SvROK(errsv)) {
            exsv = errsv;
            if (sv_isobject(exsv)) {
@@ -517,7 +514,7 @@ PP(pp_die)
                }
            }
        }
-       else if (SvPV_const(errsv, len), len) {
+       else if (SvPOK(errsv) && SvCUR(errsv)) {
            exsv = sv_mortalcopy(errsv);
            sv_catpvs(exsv, "\t...propagated");
        }
@@ -531,7 +528,7 @@ PP(pp_die)
 /* I/O. */
 
 OP *
-Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
+Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
                 const MAGIC *const mg, const U32 flags, U32 argc, ...)
 {
     SV **orig_sp = sp;
@@ -575,7 +572,7 @@ Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
        SAVEGENERICSV(PL_ors_sv);
        PL_ors_sv = newSVpvs("\n");
     }
-    ret_args = call_method(methname, flags & G_WANT);
+    ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
     SPAGAIN;
     orig_sp = sp;
     POPSTACK;
@@ -626,7 +623,7 @@ PP(pp_open)
        if (mg) {
            /* Method's args are same as ours ... */
            /* ... except handle is replaced by the object */
-           return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
+           return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
                                    G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
                                    sp - mark);
        }
@@ -665,7 +662,7 @@ PP(pp_close)
        if (io) {
            const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
            if (mg) {
-               return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg);
+               return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
            }
        }
     }
@@ -748,7 +745,7 @@ PP(pp_fileno)
     if (io
        && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
     {
-       return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
+       return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
     }
 
     if (!io || !(fp = IoIFP(io))) {
@@ -819,7 +816,7 @@ PP(pp_binmode)
               function, which I don't think that the optimiser will be able to
               figure out. Although, as it's a static function, in theory it
               could.  */
-           return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg,
+           return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
                                    G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
                                    discp ? 1 : 0, discp);
        }
@@ -902,6 +899,10 @@ PP(pp_tie)
                varsv = MUTABLE_SV(GvIOp(varsv));
                break;
            }
+           if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
+               vivify_defelem(varsv);
+               varsv = LvTARG(varsv);
+           }
            /* FALL THROUGH */
        default:
            methname = "TIESCALAR";
@@ -970,6 +971,9 @@ PP(pp_untie)
     if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
        RETPUSHYES;
 
+    if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
+       !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
+
     if ((mg = SvTIED_mg(sv, how))) {
        SV * const obj = SvRV(SvTIED_obj(sv, mg));
         if (obj) {
@@ -1008,6 +1012,9 @@ PP(pp_tied)
     if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
        RETPUSHUNDEF;
 
+    if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
+       !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
+
     if ((mg = SvTIED_mg(sv, how))) {
        PUSHs(SvTIED_obj(sv, mg));
        RETURN;
@@ -1105,10 +1112,11 @@ PP(pp_sselect)
        SvGETMAGIC(sv);
        if (!SvOK(sv))
            continue;
-       if (SvIsCOW(sv))
-               sv_force_normal_flags(sv, 0);
-       if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
+       if (SvREADONLY(sv)) {
+           if (!(SvPOK(sv) && SvCUR(sv) == 0))
                Perl_croak_no_modify();
+       }
+       else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
        if (!SvPOK(sv)) {
            if (!SvPOKp(sv))
                Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
@@ -1301,7 +1309,7 @@ PP(pp_getc)
        const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
        if (mg) {
            const U32 gimme = GIMME_V;
-           Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
+           Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
            if (gimme == G_SCALAR) {
                SPAGAIN;
                SvSetMagicSV_nosteal(TARG, TOPs);
@@ -1473,8 +1481,7 @@ PP(pp_leavewrite)
        PL_formtarget = PL_toptarget;
        IoFLAGS(io) |= IOf_DIDTOP;
        fgv = IoTOP_GV(io);
-       if (!fgv)
-           DIE(aTHX_ "bad top format reference");
+       assert(fgv); /* IoTOP_GV(io) should have been set above */
        cv = GvFORM(fgv);
        if (!cv) {
            SV * const sv = sv_newmortal();
@@ -1539,7 +1546,7 @@ PP(pp_prtf)
                Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
                ++SP;
            }
-           return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
+           return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
                                    mg,
                                    G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
                                    sp - mark);
@@ -1628,7 +1635,7 @@ PP(pp_sysread)
     {
        const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
        if (mg) {
-           return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg,
+           return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
                                    G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
                                    sp - mark);
        }
@@ -1866,7 +1873,7 @@ PP(pp_syswrite)
                PUTBACK;
            }
 
-           return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg,
+           return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
                                    G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
                                    sp - mark);
        }
@@ -2079,7 +2086,7 @@ PP(pp_eof)
        RETPUSHNO;
 
     if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
-       return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which));
+       return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
     }
 
     if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) {  /* eof() */
@@ -2119,7 +2126,7 @@ PP(pp_tell)
     if (io) {
        const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
        if (mg) {
-           return tied_method0("TELL", SP, MUTABLE_SV(io), mg);
+           return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
        }
     }
     else if (!gv) {
@@ -2159,7 +2166,7 @@ PP(pp_sysseek)
            SV *const offset_sv = newSViv(offset);
 #endif
 
-           return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv,
+           return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
                                newSViv(whence));
        }
     }
@@ -2846,24 +2853,10 @@ PP(pp_stat)
 #endif
        mPUSHu(PL_statcache.st_mode);
        mPUSHu(PL_statcache.st_nlink);
-#if Uid_t_size > IVSIZE
-       mPUSHn(PL_statcache.st_uid);
-#else
-#   if Uid_t_sign <= 0
-       mPUSHi(PL_statcache.st_uid);
-#   else
-       mPUSHu(PL_statcache.st_uid);
-#   endif
-#endif
-#if Gid_t_size > IVSIZE
-       mPUSHn(PL_statcache.st_gid);
-#else
-#   if Gid_t_sign <= 0
-       mPUSHi(PL_statcache.st_gid);
-#   else
-       mPUSHu(PL_statcache.st_gid);
-#   endif
-#endif
+       
+        sv_setuid(PUSHmortal, PL_statcache.st_uid);
+        sv_setgid(PUSHmortal, PL_statcache.st_gid);
+
 #ifdef USE_STAT_RDEV
        mPUSHi(PL_statcache.st_rdev);
 #else
@@ -3685,13 +3678,7 @@ S_dooneliner(pTHX_ const char *cmd, const char *filename)
                 ; e++)
            {
                /* you don't see this */
-               const char * const errmsg =
-#ifdef HAS_SYS_ERRLIST
-                   sys_errlist[e]
-#else
-                   strerror(e)
-#endif
-                   ;
+               const char * const errmsg = Strerror(e) ;
                if (!errmsg)
                    break;
                if (instr(s, errmsg)) {
@@ -4945,9 +4932,7 @@ PP(pp_gservent)
 #ifdef HAS_GETSERVBYPORT
        const char * const proto = POPpbytex;
        unsigned short port = (unsigned short)POPu;
-#ifdef HAS_HTONS
        port = PerlSock_htons(port);
-#endif
        sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
 #else
        DIE(aTHX_ PL_no_sock_func, "getservbyport");
@@ -4965,11 +4950,7 @@ PP(pp_gservent)
        PUSHs(sv = sv_newmortal());
        if (sent) {
            if (which == OP_GSBYNAME) {
-#ifdef HAS_NTOHS
                sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
-#else
-               sv_setiv(sv, (IV)(sent->s_port));
-#endif
            }
            else
                sv_setpv(sv, sent->s_name);
@@ -4980,11 +4961,7 @@ PP(pp_gservent)
     if (sent) {
        mPUSHs(newSVpv(sent->s_name, 0));
        PUSHs(space_join_names_mortal(sent->s_aliases));
-#ifdef HAS_NTOHS
        mPUSHi(PerlSock_ntohs(sent->s_port));
-#else
-       mPUSHi(sent->s_port);
-#endif
        mPUSHs(newSVpv(sent->s_proto, 0));
     }
 
@@ -5199,11 +5176,7 @@ PP(pp_gpwent)
        PUSHs(sv = sv_newmortal());
        if (pwent) {
            if (which == OP_GPWNAM)
-#   if Uid_t_sign <= 0
-               sv_setiv(sv, (IV)pwent->pw_uid);
-#   else
-               sv_setuv(sv, (UV)pwent->pw_uid);
-#   endif
+               sv_setuid(sv, pwent->pw_uid);
            else
                sv_setpv(sv, pwent->pw_name);
        }
@@ -5257,17 +5230,9 @@ PP(pp_gpwent)
        SvTAINTED_on(sv);
 #   endif
 
-#   if Uid_t_sign <= 0
-       mPUSHi(pwent->pw_uid);
-#   else
-       mPUSHu(pwent->pw_uid);
-#   endif
+        sv_setuid(PUSHmortal, pwent->pw_uid);
+        sv_setgid(PUSHmortal, pwent->pw_gid);
 
-#   if Uid_t_sign <= 0
-       mPUSHi(pwent->pw_gid);
-#   else
-       mPUSHu(pwent->pw_gid);
-#   endif
        /* pw_change, pw_quota, and pw_age are mutually exclusive--
         * because of the poor interface of the Perl getpw*(),
         * not because there's some standard/convention saying so.
@@ -5358,11 +5323,7 @@ PP(pp_ggrent)
        PUSHs(sv);
        if (grent) {
            if (which == OP_GGRNAM)
-#if Gid_t_sign <= 0
-               sv_setiv(sv, (IV)grent->gr_gid);
-#else
-               sv_setuv(sv, (UV)grent->gr_gid);
-#endif
+               sv_setgid(sv, grent->gr_gid);
            else
                sv_setpv(sv, grent->gr_name);
        }
@@ -5378,11 +5339,7 @@ PP(pp_ggrent)
        PUSHs(sv_mortalcopy(&PL_sv_no));
 #endif
 
-#if Gid_t_sign <= 0
-       mPUSHi(grent->gr_gid);
-#else
-       mPUSHu(grent->gr_gid);
-#endif
+        sv_setgid(PUSHmortal, grent->gr_gid);
 
 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
        /* In UNICOS/mk (_CRAYMPP) the multithreading