diag.t: Let diag.t be run on specific source files

[perl5.git] / pp_sys.c

diff --git a/pp_sys.c b/pp_sys.c
index b5efeb4..78308f4 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -476,7 +476,8 @@ PP(pp_die)
     SV *exsv;
     STRLEN len;
 #ifdef VMS
-    VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
+    VMSISH_HUSHED  =
+       VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
 #endif
     if (SP - MARK != 1) {
        dTARGET;
@@ -528,7 +529,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;
@@ -572,7 +573,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;
@@ -623,7 +624,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);
        }
@@ -662,7 +663,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);
            }
        }
     }
@@ -745,7 +746,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))) {
@@ -816,7 +817,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);
        }
@@ -899,6 +900,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";
@@ -967,6 +972,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) {
@@ -1005,6 +1013,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;
@@ -1102,10 +1113,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),
@@ -1148,8 +1160,9 @@ PP(pp_sselect)
 #  endif
 
     sv = SP[4];
+    SvGETMAGIC(sv);
     if (SvOK(sv)) {
-       value = SvNV(sv);
+       value = SvNV_nomg(sv);
        if (value < 0.0)
            value = 0.0;
        timebuf.tv_sec = (long)value;
@@ -1298,7 +1311,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);
@@ -1470,8 +1483,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();
@@ -1483,8 +1495,8 @@ PP(pp_leavewrite)
 
   forget_top:
     POPBLOCK(cx,PL_curpm);
-    POPFORMAT(cx);
     retop = cx->blk_sub.retop;
+    POPFORMAT(cx);
     SP = newsp; /* ignore retval of formline */
     LEAVE;
 
@@ -1536,7 +1548,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);
@@ -1625,7 +1637,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);
        }
@@ -1759,20 +1771,6 @@ PP(pp_sysread)
        }
     }
     else
-#ifdef HAS_SOCKET__bad_code_maybe
-    if (IoTYPE(io) == IoTYPE_SOCKET) {
-       Sock_size_t bufsize;
-       char namebuf[MAXPATHLEN];
-#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
-       bufsize = sizeof (struct sockaddr_in);
-#else
-       bufsize = sizeof namebuf;
-#endif
-       count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
-                         (struct sockaddr *)namebuf, &bufsize);
-    }
-    else
-#endif
     {
        count = PerlIO_read(IoIFP(io), buffer, length);
        /* PerlIO_read() - like fread() returns 0 on both error and EOF */
@@ -1863,7 +1861,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);
        }
@@ -2076,7 +2074,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() */
@@ -2116,7 +2114,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) {
@@ -2156,7 +2154,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));
        }
     }
@@ -3278,7 +3276,7 @@ PP(pp_fttext)
 {
     dVAR;
     I32 i;
-    I32 len;
+    SSize_t len;
     I32 odd = 0;
     STDCHAR tbuf[512];
     STDCHAR *s;
@@ -3614,9 +3612,7 @@ PP(pp_readlink)
     char buf[MAXPATHLEN];
     int len;
 
-#ifndef INCOMPLETE_TAINTS
     TAINT;
-#endif
     tmps = POPpconstx;
     len = readlink(tmps, buf, sizeof(buf) - 1);
     if (len < 0)
@@ -3668,13 +3664,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)) {
@@ -3851,10 +3841,8 @@ PP(pp_readdir)
 #else
         sv = newSVpv(dp->d_name, 0);
 #endif
-#ifndef INCOMPLETE_TAINTS
         if (!(IoFLAGS(io) & IOf_UNTAINT))
             SvTAINTED_on(sv);
-#endif
         mXPUSHs(sv);
     } while (gimme == G_ARRAY);
 
@@ -3995,13 +3983,13 @@ PP(pp_fork)
 #ifdef HAS_FORK
     dVAR; dSP; dTARGET;
     Pid_t childpid;
-#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+#ifdef HAS_SIGPROCMASK
     sigset_t oldmask, newmask;
 #endif
 
     EXTEND(SP, 1);
     PERL_FLUSHALL_FOR_CHILD;
-#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+#ifdef HAS_SIGPROCMASK
     sigfillset(&newmask);
     sigprocmask(SIG_SETMASK, &newmask, &oldmask);
 #endif
@@ -4013,7 +4001,7 @@ PP(pp_fork)
            for (sig = 1; sig < SIG_SIZE; sig++)
                PL_psig_pend[sig] = 0;
     }
-#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+#ifdef HAS_SIGPROCMASK
     {
        dSAVE_ERRNO;
        sigprocmask(SIG_SETMASK, &oldmask, NULL);
@@ -4132,13 +4120,13 @@ PP(pp_system)
        Pid_t childpid;
        int pp[2];
        I32 did_pipes = 0;
-#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+#ifdef HAS_SIGPROCMASK
        sigset_t newset, oldset;
 #endif
 
        if (PerlProc_pipe(pp) >= 0)
            did_pipes = 1;
-#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+#ifdef HAS_SIGPROCMASK
        sigemptyset(&newset);
        sigaddset(&newset, SIGCHLD);
        sigprocmask(SIG_BLOCK, &newset, &oldset);
@@ -4152,7 +4140,7 @@ PP(pp_system)
                    PerlLIO_close(pp[0]);
                    PerlLIO_close(pp[1]);
                }
-#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+#ifdef HAS_SIGPROCMASK
                sigprocmask(SIG_SETMASK, &oldset, NULL);
 #endif
                RETURN;
@@ -4206,7 +4194,7 @@ PP(pp_system)
            XPUSHi(STATUS_CURRENT);
            RETURN;
        }
-#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+#ifdef HAS_SIGPROCMASK
        sigprocmask(SIG_SETMASK, &oldset, NULL);
 #endif
        if (did_pipes) {
@@ -5220,11 +5208,9 @@ PP(pp_gpwent)
            sv_setpv(sv, pwent->pw_passwd);
 #   endif
 
-#   ifndef INCOMPLETE_TAINTS
        /* passwd is tainted because user himself can diddle with it.
         * admittedly not much and in a very limited way, but nevertheless. */
        SvTAINTED_on(sv);
-#   endif
 
         sv_setuid(PUSHmortal, pwent->pw_uid);
         sv_setgid(PUSHmortal, pwent->pw_gid);
@@ -5267,18 +5253,14 @@ PP(pp_gpwent)
 #   else
        PUSHs(sv = sv_mortalcopy(&PL_sv_no));
 #   endif
-#   ifndef INCOMPLETE_TAINTS
        /* pw_gecos is tainted because user himself can diddle with it. */
        SvTAINTED_on(sv);
-#   endif
 
        mPUSHs(newSVpv(pwent->pw_dir, 0));
 
        PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
-#   ifndef INCOMPLETE_TAINTS
        /* pw_shell is tainted because user himself can diddle with it. */
        SvTAINTED_on(sv);
-#   endif
 
 #   ifdef PWEXPIRE
        mPUSHi(pwent->pw_expire);