X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2e8ea15a11326145a7df027b5b2507ff3d7483ba..5b5bb2e084609b4187dde7e0f27927f06f871ad8:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index f7e930f..2515277 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -213,8 +213,8 @@ void endservent(void); #endif #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF) - /* AIX */ -# define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF)) + /* AIX's accessx() doesn't declare its argument const, unlike every other platform */ +# define PERL_EFF_ACCESS(p,f) (accessx((char*)(p), (f), ACC_SELF)) #endif @@ -417,7 +417,7 @@ PP(pp_warn) } else if (SP == MARK) { exsv = &PL_sv_no; - EXTEND(SP, 1); + MEXTEND(SP, 1); SP = MARK + 1; } else { @@ -498,7 +498,7 @@ PP(pp_die) } } } - else if (SvPOK(errsv) && SvCUR(errsv)) { + else if (SvOK(errsv) && (SvPV_nomg(errsv,len), len)) { exsv = sv_mortalcopy(errsv); sv_catpvs(exsv, "\t...propagated"); } @@ -690,7 +690,7 @@ PP(pp_pipe_op) if (IoIFP(wstio)) do_close(wgv, FALSE); - if (PerlProc_pipe(fd) < 0) + if (PerlProc_pipe_cloexec(fd) < 0) goto badexit; IoIFP(rstio) = PerlIO_fdopen(fd[0], "r" PIPE_OPEN_MODE); @@ -711,12 +711,6 @@ PP(pp_pipe_op) PerlLIO_close(fd[1]); goto badexit; } -#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) - /* ensure close-on-exec */ - if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) || - (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0)) - goto badexit; -#endif RETPUSHYES; badexit: @@ -1731,10 +1725,9 @@ PP(pp_sysread) if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) { if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "%s() is deprecated on :utf8 handles. " - "This will be a fatal error in Perl 5.30", - OP_DESC(PL_op)); + Perl_croak(aTHX_ + "%s() isn't allowed on :utf8 handles", + OP_DESC(PL_op)); } buffer = SvPVutf8_force(bufsv, blen); /* UTF-8 may not have been set if they are all low bytes */ @@ -1743,7 +1736,7 @@ PP(pp_sysread) } else { buffer = SvPV_force(bufsv, blen); - buffer_utf8 = !IN_BYTES && SvUTF8(bufsv); + buffer_utf8 = DO_UTF8(bufsv); } if (DO_UTF8(bufsv)) { blen = sv_len_utf8_nomg(bufsv); @@ -1945,7 +1938,6 @@ PP(pp_syswrite) const char *buffer; SSize_t retval; STRLEN blen; - STRLEN orig_blen_bytes; const int op_type = PL_op->op_type; bool doing_utf8; U8 *tmpbuf = NULL; @@ -1991,20 +1983,12 @@ PP(pp_syswrite) /* Do this first to trigger any overloading. */ buffer = SvPV_const(bufsv, blen); - orig_blen_bytes = blen; doing_utf8 = DO_UTF8(bufsv); if (PerlIO_isutf8(IoIFP(io))) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "%s() is deprecated on :utf8 handles. " - "This will be a fatal error in Perl 5.30", - OP_DESC(PL_op)); - if (!SvUTF8(bufsv)) { - /* We don't modify the original scalar. */ - tmpbuf = bytes_to_utf8((const U8*) buffer, &blen); - buffer = (char *) tmpbuf; - doing_utf8 = TRUE; - } + Perl_croak(aTHX_ + "%s() isn't allowed on :utf8 handles", + OP_DESC(PL_op)); } else if (doing_utf8) { STRLEN tmplen = blen; @@ -2037,25 +2021,10 @@ PP(pp_syswrite) #endif { Size_t length = 0; /* This length is in characters. */ - STRLEN blen_chars; IV offset; - if (doing_utf8) { - if (tmpbuf) { - /* The SV is bytes, and we've had to upgrade it. */ - blen_chars = orig_blen_bytes; - } else { - /* The SV really is UTF-8. */ - /* Don't call sv_len_utf8 on a magical or overloaded - scalar, as we might get back a different result. */ - blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen); - } - } else { - blen_chars = blen; - } - if (MARK >= SP) { - length = blen_chars; + length = blen; } else { #if Size_t_size > IVSIZE length = (Size_t)SvNVx(*++MARK); @@ -2071,46 +2040,21 @@ PP(pp_syswrite) if (MARK < SP) { offset = SvIVx(*++MARK); if (offset < 0) { - if (-offset > (IV)blen_chars) { + if (-offset > (IV)blen) { Safefree(tmpbuf); DIE(aTHX_ "Offset outside string"); } - offset += blen_chars; - } else if (offset > (IV)blen_chars) { + offset += blen; + } else if (offset > (IV)blen) { Safefree(tmpbuf); DIE(aTHX_ "Offset outside string"); } } else offset = 0; - if (length > blen_chars - offset) - length = blen_chars - offset; - if (doing_utf8) { - /* Here we convert length from characters to bytes. */ - if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) { - /* Either we had to convert the SV, or the SV is magical, or - the SV has overloading, in which case we can't or mustn't - or mustn't call it again. */ - - buffer = (const char*)utf8_hop((const U8 *)buffer, offset); - length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer; - } else { - /* It's a real UTF-8 SV, and it's not going to change under - us. Take advantage of any cache. */ - I32 start = offset; - I32 len_I32 = length; - - /* Convert the start and end character positions to bytes. - Remember that the second argument to sv_pos_u2b is relative - to the first. */ - sv_pos_u2b(bufsv, &start, &len_I32); - - buffer += start; - length = len_I32; - } - } - else { - buffer = buffer+offset; - } + if (length > blen - offset) + length = blen - offset; + buffer = buffer+offset; + #ifdef PERL_SOCK_SYSWRITE_IS_SEND if (IoTYPE(io) == IoTYPE_SOCKET) { retval = PerlSock_send(fd, buffer, length, 0); @@ -2126,8 +2070,6 @@ PP(pp_syswrite) if (retval < 0) goto say_undef; SP = ORIGMARK; - if (doing_utf8) - retval = utf8_length((U8*)buffer, (U8*)buffer + retval); Safefree(tmpbuf); #if Size_t_size > IVSIZE @@ -2179,7 +2121,7 @@ PP(pp_eof) } if (!gv) - RETPUSHNO; + RETPUSHYES; if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which)); @@ -2379,7 +2321,7 @@ PP(pp_truncate) */ mode |= O_BINARY; #endif - tmpfd = PerlLIO_open(name, mode); + tmpfd = PerlLIO_open_cloexec(name, mode); if (tmpfd < 0) { result = 0; @@ -2521,7 +2463,7 @@ PP(pp_socket) do_close(gv, FALSE); TAINT_PROPER("socket"); - fd = PerlSock_socket(domain, type, protocol); + fd = PerlSock_socket_cloexec(domain, type, protocol); if (fd < 0) { RETPUSHUNDEF; } @@ -2534,11 +2476,6 @@ PP(pp_socket) if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd); RETPUSHUNDEF; } -#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) - /* ensure close-on-exec */ - if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) - RETPUSHUNDEF; -#endif RETPUSHYES; } @@ -2564,7 +2501,7 @@ PP(pp_sockpair) do_close(gv2, FALSE); TAINT_PROPER("socketpair"); - if (PerlSock_socketpair(domain, type, protocol, fd) < 0) + if (PerlSock_socketpair_cloexec(domain, type, protocol, fd) < 0) RETPUSHUNDEF; IoIFP(io1) = PerlIO_fdopen(fd[0], "r" SOCKET_OPEN_MODE); IoOFP(io1) = PerlIO_fdopen(fd[0], "w" SOCKET_OPEN_MODE); @@ -2581,12 +2518,6 @@ PP(pp_sockpair) if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]); RETPUSHUNDEF; } -#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) - /* ensure close-on-exec */ - if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) || - (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0)) - RETPUSHUNDEF; -#endif RETPUSHYES; #else @@ -2673,7 +2604,7 @@ PP(pp_accept) goto nuts; nstio = GvIOn(ngv); - fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len); + fd = PerlSock_accept_cloexec(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len); #if defined(OEMVS) if (len == 0) { /* Some platforms indicate zero length when an AF_UNIX client is @@ -2698,11 +2629,6 @@ PP(pp_accept) if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd); goto badexit; } -#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) - /* ensure close-on-exec */ - if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) - goto badexit; -#endif #ifdef __SCO_VERSION__ len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */ @@ -2915,10 +2841,11 @@ PP(pp_stat) Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); } - if (gv != PL_defgv) { - bool havefp; + if (gv == PL_defgv) { + if (PL_laststatval < 0) + SETERRNO(EBADF,RMS_IFI); + } else { do_fstat_have_io: - havefp = FALSE; PL_laststype = OP_STAT; PL_statgv = gv ? gv : (GV *)io; SvPVCLEAR(PL_statname); @@ -2929,22 +2856,25 @@ PP(pp_stat) if (IoIFP(io)) { int fd = PerlIO_fileno(IoIFP(io)); if (fd < 0) { + report_evil_fh(gv); PL_laststatval = -1; SETERRNO(EBADF,RMS_IFI); } else { PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); - havefp = TRUE; } } else if (IoDIRP(io)) { PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache); - havefp = TRUE; } else { + report_evil_fh(gv); PL_laststatval = -1; + SETERRNO(EBADF,RMS_IFI); } - } - else PL_laststatval = -1; - if (PL_laststatval < 0 && !havefp) report_evil_fh(gv); + } else { + report_evil_fh(gv); + PL_laststatval = -1; + SETERRNO(EBADF,RMS_IFI); + } } if (PL_laststatval < 0) { @@ -2977,9 +2907,9 @@ PP(pp_stat) if (PL_laststatval < 0) { if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { /* PL_warn_nl is constant */ - GCC_DIAG_IGNORE(-Wformat-nonliteral); + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; } max = 0; } @@ -3010,9 +2940,11 @@ PP(pp_stat) */ bool neg; Stat_t s; - GCC_DIAG_IGNORE(-Wtype-limits); + CLANG_DIAG_IGNORE_STMT(-Wtautological-compare); + GCC_DIAG_IGNORE_STMT(-Wtype-limits); neg = PL_statcache.st_ino < 0; - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; + CLANG_DIAG_RESTORE_STMT; if (neg) { s.st_ino = (IV)PL_statcache.st_ino; if (LIKELY(s.st_ino == PL_statcache.st_ino)) { @@ -3110,7 +3042,7 @@ S_ft_return_false(pTHX_ SV *ret) { PUTBACK; if (PL_op->op_private & OPpFT_STACKING) { - while (OP_IS_FILETEST(next->op_type) + while (next && OP_IS_FILETEST(next->op_type) && next->op_private & OPpFT_STACKED) next = next->op_next; } @@ -3368,24 +3300,6 @@ PP(pp_ftrowned) } tryAMAGICftest_MG(opchar); - /* I believe that all these three are likely to be defined on most every - system these days. */ -#ifndef S_ISUID - if(PL_op->op_type == OP_FTSUID) { - FT_RETURNNO; - } -#endif -#ifndef S_ISGID - if(PL_op->op_type == OP_FTSGID) { - FT_RETURNNO; - } -#endif -#ifndef S_ISVTX - if(PL_op->op_type == OP_FTSVTX) { - FT_RETURNNO; - } -#endif - result = my_stat_flags(0); if (result < 0) FT_RETURNUNDEF; @@ -3487,7 +3401,7 @@ PP(pp_fttty) else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX) fd = (int)uv; else - FT_RETURNUNDEF; + fd = -1; if (fd < 0) { SETERRNO(EBADF,RMS_IFI); FT_RETURNUNDEF; @@ -3511,6 +3425,7 @@ PP(pp_fttext) SV *sv = NULL; GV *gv; PerlIO *fp; + const U8 * first_variant; tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B'); @@ -3604,9 +3519,9 @@ PP(pp_fttext) } if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { /* PL_warn_nl is constant */ - GCC_DIAG_IGNORE(-Wformat-nonliteral); + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; } FT_RETURNUNDEF; } @@ -3644,11 +3559,14 @@ PP(pp_fttext) #endif assert(len); - if (! is_utf8_invariant_string((U8 *) s, len)) { + if (! is_utf8_invariant_string_loc((U8 *) s, len, &first_variant)) { /* Here contains a variant under UTF-8 . See if the entire string is * UTF-8. */ - if (is_utf8_fixed_width_buf_flags((U8 *) s, len, 0)) { + if (is_utf8_fixed_width_buf_flags(first_variant, + len - ((char *) first_variant - (char *) s), + 0)) + { if (PL_op->op_type == OP_FTTEXT) { FT_RETURNYES; } @@ -3906,8 +3824,7 @@ PP(pp_readlink) len = readlink(tmps, buf, sizeof(buf) - 1); if (len < 0) RETPUSHUNDEF; - if (len != -1) - buf[len] = '\0'; + buf[len] = '\0'; PUSHp(buf, len); RETURN; #else @@ -4400,14 +4317,45 @@ PP(pp_system) int result; # endif + while (++MARK <= SP) { + SV *origsv = *MARK, *copysv; + STRLEN len; + char *pv; + SvGETMAGIC(origsv); +#if defined(WIN32) || defined(__VMS) + /* + * Because of a nasty platform-specific variation on the meaning + * of arguments to this op, we must preserve numeric arguments + * as numeric, not just retain the string value. + */ + if (SvNIOK(origsv) || SvNIOKp(origsv)) { + copysv = newSV_type(SVt_PVNV); + sv_2mortal(copysv); + if (SvPOK(origsv) || SvPOKp(origsv)) { + pv = SvPV_nomg(origsv, len); + sv_setpvn(copysv, pv, len); + SvPOK_off(copysv); + } + if (SvIOK(origsv) || SvIOKp(origsv)) + SvIV_set(copysv, SvIVX(origsv)); + if (SvNOK(origsv) || SvNOKp(origsv)) + SvNV_set(copysv, SvNVX(origsv)); + SvFLAGS(copysv) |= SvFLAGS(origsv) & + (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK| + SVf_UTF8|SVf_IVisUV); + } else +#endif + { + pv = SvPV_nomg(origsv, len); + copysv = newSVpvn_flags(pv, len, + (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP); + } + *MARK = copysv; + } + MARK = ORIGMARK; + if (TAINTING_get) { TAINT_ENV(); - while (++MARK <= SP) { - (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ - if (TAINT_get) - break; - } - MARK = ORIGMARK; TAINT_PROPER("system"); } PERL_FLUSHALL_FOR_CHILD; @@ -4426,7 +4374,7 @@ PP(pp_system) sigset_t newset, oldset; #endif - if (PerlProc_pipe(pp) >= 0) + if (PerlProc_pipe_cloexec(pp) >= 0) did_pipes = 1; #ifdef __amigaos4__ amigaos_fork_set_userdata(aTHX_ @@ -4488,7 +4436,6 @@ PP(pp_system) (void)rsignal_restore(SIGQUIT, &qhand); #endif STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status); - do_execfree(); /* free any memory child malloced on fork */ SP = ORIGMARK; if (did_pipes) { int errkid; @@ -4524,13 +4471,8 @@ PP(pp_system) #ifdef HAS_SIGPROCMASK sigprocmask(SIG_SETMASK, &oldset, NULL); #endif - if (did_pipes) { + if (did_pipes) PerlLIO_close(pp[0]); -#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) - if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0) - RETPUSHUNDEF; -#endif - } if (PL_op->op_flags & OPf_STACKED) { SV * const really = *++MARK; value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes); @@ -4567,7 +4509,6 @@ PP(pp_system) if (PL_statusvalue == -1) /* hint that value must be returned as is */ result = 1; STATUS_NATIVE_CHILD_SET(value); - do_execfree(); SP = ORIGMARK; XPUSHi(result ? value : STATUS_CURRENT); #endif /* !FORK or VMS or OS/2 */ @@ -5338,8 +5279,8 @@ PP(pp_shostent) DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif break; -#ifdef HAS_SETNETENT case OP_SNETENT: +#ifdef HAS_SETNETENT PerlSock_setnetent(stayopen); #else DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);