utf8.c: Add flag to swash_init() to not croak on error

[perl5.git] / pp_sys.c

diff --git a/pp_sys.c b/pp_sys.c
index 19ba0cb..bd552a1 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -248,6 +248,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
     if (setresuid(euid, ruid, (Uid_t)-1))
 #endif
 #endif
+       /* diag_listed_as: entering effective %s failed */
        Perl_croak(aTHX_ "entering effective uid failed");
 #endif
 
@@ -261,6 +262,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
     if (setresgid(egid, rgid, (Gid_t)-1))
 #endif
 #endif
+       /* diag_listed_as: entering effective %s failed */
        Perl_croak(aTHX_ "entering effective gid failed");
 #endif
 
@@ -273,6 +275,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
     if (setresuid(ruid, euid, (Uid_t)-1))
 #endif
 #endif
+       /* diag_listed_as: leaving effective %s failed */
        Perl_croak(aTHX_ "leaving effective uid failed");
 
 #ifdef HAS_SETREGID
@@ -282,6 +285,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
     if (setresgid(rgid, egid, (Gid_t)-1))
 #endif
 #endif
+       /* diag_listed_as: leaving effective %s failed */
        Perl_croak(aTHX_ "leaving effective gid failed");
 
     return res;
@@ -355,9 +359,9 @@ PP(pp_glob)
     dVAR;
     OP *result;
     dSP;
-    /* make a copy of the pattern, to ensure that magic is called once
-     * and only once */
-    TOPm1s = sv_2mortal(newSVsv(TOPm1s));
+    /* make a copy of the pattern if it is gmagical, to ensure that magic
+     * is called once and only once */
+    if (SvGMAGICAL(TOPm1s)) TOPm1s = sv_2mortal(newSVsv(TOPm1s));
 
     tryAMAGICunTARGET(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
 
@@ -370,6 +374,11 @@ PP(pp_glob)
     }
     /* stack args are: wildcard, gv(_GEN_n) */
 
+    if (PL_globhook) {
+       SETs(GvSV(TOPs));
+       PL_globhook(aTHX);
+       return NORMAL;
+    }
 
     /* Note that we only ever get here if File::Glob fails to load
      * without at the same time croaking, for some reason, or if
@@ -848,6 +857,13 @@ PP(pp_tie)
            break;
        case SVt_PVAV:
            methname = "TIEARRAY";
+           if (!AvREAL(varsv)) {
+               if (!AvREIFY(varsv))
+                   Perl_croak(aTHX_ "Cannot tie unreifiable array");
+               av_clear((AV *)varsv);
+               AvREIFY_off(varsv);
+               AvREAL_on(varsv);
+           }
            break;
        case SVt_PVGV:
        case SVt_PVLV:
@@ -968,10 +984,7 @@ PP(pp_tied)
        RETPUSHUNDEF;
 
     if ((mg = SvTIED_mg(sv, how))) {
-       SV *osv = SvTIED_obj(sv, mg);
-       if (osv == mg->mg_obj)
-           osv = sv_mortalcopy(osv);
-       PUSHs(osv);
+       PUSHs(SvTIED_obj(sv, mg));
        RETURN;
     }
     RETPUSHUNDEF;
@@ -1004,7 +1017,10 @@ PP(pp_dbmopen)
     if (SvIV(right))
        mPUSHu(O_RDWR|O_CREAT);
     else
+    {
        mPUSHu(O_RDWR);
+       if (!SvOK(right)) right = &PL_sv_no;
+    }
     PUSHs(right);
     PUTBACK;
     call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
@@ -1061,6 +1077,7 @@ PP(pp_sselect)
     SP -= 4;
     for (i = 1; i <= 3; i++) {
        SV * const sv = SP[i];
+       SvGETMAGIC(sv);
        if (!SvOK(sv))
            continue;
        if (SvREADONLY(sv)) {
@@ -1070,8 +1087,10 @@ PP(pp_sselect)
                Perl_croak_no_modify(aTHX);
        }
        if (!SvPOK(sv)) {
-           Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
-           SvPV_force_nolen(sv);       /* force string conversion */
+           if (!SvPOKp(sv))
+               Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+                                   "Non-string passed as bitmask");
+           SvPV_force_nomg_nolen(sv);  /* force string conversion */
        }
        j = SvCUR(sv);
        if (maxlen < j)
@@ -1219,21 +1238,20 @@ PP(pp_select)
     HV *hv;
     GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
     GV * egv = GvEGVx(PL_defoutgv);
+    GV * const *gvp;
 
     if (!egv)
        egv = PL_defoutgv;
     hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
-    if (! hv)
-       XPUSHs(&PL_sv_undef);
-    else {
-       GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE);
-       if (gvp && *gvp == egv) {
+    gvp = hv && HvENAME(hv)
+               ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
+               : NULL;
+    if (gvp && *gvp == egv) {
            gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
            XPUSHTARG;
-       }
-       else {
+    }
+    else {
            mXPUSHs(newRV(MUTABLE_SV(egv)));
-       }
     }
 
     if (newdefout) {
@@ -3230,7 +3248,6 @@ PP(pp_fttty)
     dSP;
     int fd;
     GV *gv;
-    SV *tmpsv = NULL;
     char *name = NULL;
     STRLEN namelen;
 
@@ -3240,20 +3257,18 @@ PP(pp_fttty)
 
     if (PL_op->op_flags & OPf_REF)
        gv = cGVOP_gv;
-    else if (!(gv = MAYBE_DEREF_GV_nomg(TOPs))) {
-       tmpsv = POPs;
+    else {
+      SV *tmpsv = POPs;
+      if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
        name = SvPV_nomg(tmpsv, namelen);
        gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
+      }
     }
 
     if (GvIO(gv) && IoIFP(GvIOp(gv)))
        fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
-    else if (tmpsv && SvOK(tmpsv)) {
-       if (isDIGIT(*name))
+    else if (name && isDIGIT(*name))
            fd = atoi(name);
-       else 
-           RETPUSHUNDEF;
-    }
     else
        RETPUSHUNDEF;
     if (PerlLIO_isatty(fd))
@@ -3279,7 +3294,7 @@ PP(pp_fttext)
     STDCHAR tbuf[512];
     register STDCHAR *s;
     register IO *io;
-    register SV *sv;
+    register SV *sv = NULL;
     GV *gv;
     PerlIO *fp;
 
@@ -3289,7 +3304,9 @@ PP(pp_fttext)
 
     if (PL_op->op_flags & OPf_REF)
        gv = cGVOP_gv;
-    else gv = MAYBE_DEREF_GV_nomg(TOPs);
+    else if (PL_op->op_private & OPpFT_STACKED)
+       gv = PL_defgv;
+    else sv = POPs, gv = MAYBE_DEREF_GV_nomg(sv);
 
     if (gv) {
        EXTEND(SP, 1);
@@ -3311,6 +3328,7 @@ PP(pp_fttext)
            if (! PerlIO_has_base(IoIFP(io)))
                DIE(aTHX_ "-T and -B not implemented on filehandles");
            PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
+           PL_laststype = OP_STAT;
            if (PL_laststatval < 0)
                RETPUSHUNDEF;
            if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
@@ -3333,13 +3351,12 @@ PP(pp_fttext)
                len = 512;
        }
        else {
-           report_evil_fh(cGVOP_gv);
+           report_evil_fh(gv);
            SETERRNO(EBADF,RMS_IFI);
            RETPUSHUNDEF;
        }
     }
     else {
-       sv = POPs;
       really_filename:
        PL_statgv = NULL;
        PL_laststype = OP_STAT;
@@ -4101,9 +4118,17 @@ PP(pp_system)
        Pid_t childpid;
        int pp[2];
        I32 did_pipes = 0;
+#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+       sigset_t newset, oldset;
+#endif
 
        if (PerlProc_pipe(pp) >= 0)
            did_pipes = 1;
+#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+       sigemptyset(&newset);
+       sigaddset(&newset, SIGCHLD);
+       sigprocmask(SIG_BLOCK, &newset, &oldset);
+#endif
        while ((childpid = PerlProc_fork()) == -1) {
            if (errno != EAGAIN) {
                value = -1;
@@ -4113,6 +4138,9 @@ PP(pp_system)
                    PerlLIO_close(pp[0]);
                    PerlLIO_close(pp[1]);
                }
+#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+               sigprocmask(SIG_SETMASK, &oldset, NULL);
+#endif
                RETURN;
            }
            sleep(5);
@@ -4131,6 +4159,9 @@ PP(pp_system)
                result = wait4pid(childpid, &status, 0);
            } while (result == -1 && errno == EINTR);
 #ifndef PERL_MICRO
+#ifdef HAS_SIGPROCMASK
+           sigprocmask(SIG_SETMASK, &oldset, NULL);
+#endif
            (void)rsignal_restore(SIGINT, &ihand);
            (void)rsignal_restore(SIGQUIT, &qhand);
 #endif
@@ -4161,6 +4192,9 @@ PP(pp_system)
            XPUSHi(STATUS_CURRENT);
            RETURN;
        }
+#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+       sigprocmask(SIG_SETMASK, &oldset, NULL);
+#endif
        if (did_pipes) {
            PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
@@ -4450,17 +4484,20 @@ PP(pp_gmtime)
        NV input = Perl_floor(POPn);
        when = (Time64_T)input;
        if (when != input) {
+           /* diag_listed_as: gmtime(%f) too large */
            Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
                           "%s(%.0" NVff ") too large", opname, input);
        }
     }
 
     if ( TIME_LOWER_BOUND > when ) {
+       /* diag_listed_as: gmtime(%f) too small */
        Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
                       "%s(%.0" NVff ") too small", opname, when);
        err = NULL;
     }
     else if( when > TIME_UPPER_BOUND ) {
+       /* diag_listed_as: gmtime(%f) too small */
        Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
                       "%s(%.0" NVff ") too large", opname, when);
        err = NULL;