X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/dfff4baff950c3688d6f16335fa1e1037bb84bd0..6bf09f5529fd48ed68cd24ebb1944176d9cbfc8e:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index b5efeb4..41a315d 100644 --- 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); } @@ -637,7 +638,7 @@ PP(pp_open) } tmps = SvPV_const(sv, len); - ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK)); + ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK)); SP = ORIGMARK; if (ok) PUSHi( (I32)PL_forkprocess ); @@ -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); } } } @@ -682,16 +683,13 @@ PP(pp_pipe_op) GV * const wgv = MUTABLE_GV(POPs); GV * const rgv = MUTABLE_GV(POPs); - if (!rgv || !wgv) - goto badexit; - - if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv)) - DIE(aTHX_ PL_no_usym, "filehandle"); + assert (isGV_with_GP(rgv)); + assert (isGV_with_GP(wgv)); rstio = GvIOn(rgv); - wstio = GvIOn(wgv); - if (IoIFP(rstio)) do_close(rgv, FALSE); + + wstio = GvIOn(wgv); if (IoIFP(wstio)) do_close(wgv, FALSE); @@ -717,8 +715,10 @@ PP(pp_pipe_op) goto badexit; } #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */ - fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */ + /* ensure close-on-exec */ + if ((fcntl(fd[0], F_SETFD,fd[0] > PL_maxsysfd) < 0) || + (fcntl(fd[1], F_SETFD,fd[1] > PL_maxsysfd) < 0)) + goto badexit; #endif RETPUSHYES; @@ -745,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))) { @@ -816,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); } @@ -899,7 +899,11 @@ PP(pp_tie) varsv = MUTABLE_SV(GvIOp(varsv)); break; } - /* FALL THROUGH */ + if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') { + vivify_defelem(varsv); + varsv = LvTARG(varsv); + } + /* FALLTHROUGH */ default: methname = "TIESCALAR"; how = PERL_MAGIC_tiedscalar; @@ -967,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) { @@ -998,18 +1005,23 @@ PP(pp_tied) dVAR; dSP; const MAGIC *mg; - SV *sv = POPs; + dTOPss; const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) - RETPUSHUNDEF; + goto ret_undef; + + if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' && + !(sv = defelem_target(sv, NULL))) goto ret_undef; if ((mg = SvTIED_mg(sv, how))) { - PUSHs(SvTIED_obj(sv, mg)); - RETURN; + SETs(SvTIED_obj(sv, mg)); + return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */ } - RETPUSHUNDEF; + ret_undef: + SETs(&PL_sv_undef); + return NORMAL; } PP(pp_dbmopen) @@ -1102,10 +1114,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 +1161,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; @@ -1236,7 +1250,7 @@ PP(pp_sselect) =for apidoc setdefout Sets PL_defoutgv, the default file handle for output, to the passed in -typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference +typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference count of the passed in typeglob is increased by one, and the reference count of the typeglob that PL_defoutgv points to is decreased by one. @@ -1298,7 +1312,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); @@ -1325,6 +1339,7 @@ PP(pp_getc) } SvUTF8_on(TARG); } + else SvUTF8_off(TARG); PUSHTARG; RETURN; } @@ -1338,7 +1353,7 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) PERL_ARGS_ASSERT_DOFORM; - if (cv && CvCLONE(cv)) + if (CvCLONE(cv)) cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); ENTER; @@ -1368,8 +1383,8 @@ PP(pp_enterwrite) SV *tmpsv = NULL; if (MAXARG == 0) { - gv = PL_defoutgv; EXTEND(SP, 1); + gv = PL_defoutgv; } else { gv = MUTABLE_GV(POPs); @@ -1470,8 +1485,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 +1497,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 +1550,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); @@ -1588,8 +1602,7 @@ PP(pp_sysopen) /* Need TIEHANDLE method ? */ const char * const tmps = SvPV_const(sv, len); - /* FIXME? do_open should do const */ - if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) { + if (do_open_raw(gv, tmps, len, mode, perm)) { IoLINES(GvIOp(gv)) = 0; PUSHs(&PL_sv_yes); } @@ -1618,14 +1631,15 @@ PP(pp_sysread) bool charstart = FALSE; STRLEN charskip = 0; STRLEN skip = 0; - GV * const gv = MUTABLE_GV(*++MARK); + int fd; + if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) && gv && (io = GvIO(gv)) ) { 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); } @@ -1650,6 +1664,10 @@ PP(pp_sysread) SETERRNO(EBADF,RMS_IFI); goto say_undef; } + + /* Note that fd can here validly be -1, don't check it yet. */ + fd = PerlIO_fileno(IoIFP(io)); + if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) { buffer = SvPVutf8_force(bufsv, blen); /* UTF-8 may not have been set if they are all low bytes */ @@ -1673,6 +1691,10 @@ PP(pp_sysread) if (PL_op->op_type == OP_RECV) { Sock_size_t bufsize; char namebuf[MAXPATHLEN]; + if (fd < 0) { + SETERRNO(EBADF,SS_IVCHAN); + RETPUSHUNDEF; + } #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__) bufsize = sizeof (struct sockaddr_in); #else @@ -1684,7 +1706,7 @@ PP(pp_sysread) #endif buffer = SvGROW(bufsv, (STRLEN)(length+1)); /* 'offset' means 'flags' here */ - count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset, + count = PerlSock_recvfrom(fd, buffer, length, offset, (struct sockaddr *)namebuf, &bufsize); if (count < 0) RETPUSHUNDEF; @@ -1701,6 +1723,14 @@ PP(pp_sysread) if (!(IoFLAGS(io) & IOf_UNTAINT)) SvTAINTED_on(bufsv); SP = ORIGMARK; +#if defined(__CYGWIN__) + /* recvfrom() on cygwin doesn't set bufsize at all for + connected sockets, leaving us with trash in the returned + name, so use the same test as the Win32 code to check if it + wasn't set, and set it [perl #118843] */ + if (bufsize == sizeof namebuf) + bufsize = 0; +#endif sv_setpvn(TARG, namebuf, bufsize); PUSHs(TARG); RETURN; @@ -1718,7 +1748,11 @@ PP(pp_sysread) else offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; } + more_bytes: + /* Reestablish the fd in case it shifted from underneath us. */ + fd = PerlIO_fileno(IoIFP(io)); + orig_size = SvCUR(bufsv); /* Allocating length + offset + 1 isn't perfect in the case of reading bytes from a byte file handle into a UTF8 buffer, but it won't harm us @@ -1748,31 +1782,25 @@ PP(pp_sysread) if (PL_op->op_type == OP_SYSREAD) { #ifdef PERL_SOCK_SYSREAD_IS_RECV if (IoTYPE(io) == IoTYPE_SOCKET) { - count = PerlSock_recv(PerlIO_fileno(IoIFP(io)), - buffer, length, 0); + if (fd < 0) { + SETERRNO(EBADF,SS_IVCHAN); + count = -1; + } + else + count = PerlSock_recv(fd, buffer, length, 0); } else #endif { - count = PerlLIO_read(PerlIO_fileno(IoIFP(io)), - buffer, length); + if (fd < 0) { + SETERRNO(EBADF,RMS_IFI); + count = -1; + } + else + count = PerlLIO_read(fd, buffer, length); } } 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 */ @@ -1853,6 +1881,7 @@ PP(pp_syswrite) U8 *tmpbuf = NULL; GV *const gv = MUTABLE_GV(*++MARK); IO *const io = GvIO(gv); + int fd; if (op_type == OP_SYSWRITE && io) { const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); @@ -1863,7 +1892,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); } @@ -1883,6 +1912,12 @@ PP(pp_syswrite) SETERRNO(EBADF,RMS_IFI); goto say_undef; } + fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) { + SETERRNO(EBADF,SS_IVCHAN); + retval = -1; + goto say_undef; + } /* Do this first to trigger any overloading. */ buffer = SvPV_const(bufsv, blen); @@ -1917,12 +1952,11 @@ PP(pp_syswrite) if (SP > MARK) { STRLEN mlen; char * const sockbuf = SvPVx(*++MARK, mlen); - retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, + retval = PerlSock_sendto(fd, buffer, blen, flags, (struct sockaddr *)sockbuf, mlen); } else { - retval - = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags); + retval = PerlSock_send(fd, buffer, blen, flags); } } else @@ -2005,15 +2039,13 @@ PP(pp_syswrite) } #ifdef PERL_SOCK_SYSWRITE_IS_SEND if (IoTYPE(io) == IoTYPE_SOCKET) { - retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), - buffer, length, 0); + retval = PerlSock_send(fd, buffer, length, 0); } else #endif { /* See the note at doio.c:do_print about filesize limits. --jhi */ - retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)), - buffer, length); + retval = PerlLIO_write(fd, buffer, length); } } @@ -2076,15 +2108,15 @@ 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() */ if (io && !IoIFP(io)) { - if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) { + if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) { IoLINES(io) = 0; IoFLAGS(io) &= ~IOf_START; - do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL); + do_open6(gv, "-", 1, NULL, NULL, 0); if (GvSV(gv)) sv_setpvs(GvSV(gv), "-"); else @@ -2116,7 +2148,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 +2188,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)); } } @@ -2221,13 +2253,19 @@ PP(pp_truncate) result = 0; } else { - PerlIO_flush(fp); + int fd = PerlIO_fileno(fp); + if (fd < 0) { + SETERRNO(EBADF,RMS_IFI); + result = 0; + } else { + PerlIO_flush(fp); #ifdef HAS_TRUNCATE - if (ftruncate(PerlIO_fileno(fp), len) < 0) + if (ftruncate(fd, len) < 0) #else - if (my_chsize(PerlIO_fileno(fp), len) < 0) + if (my_chsize(fd, len) < 0) #endif - result = 0; + result = 0; + } } } } @@ -2245,9 +2283,10 @@ PP(pp_truncate) { const int tmpfd = PerlLIO_open(name, O_RDWR); - if (tmpfd < 0) + if (tmpfd < 0) { + SETERRNO(EBADF,RMS_IFI); result = 0; - else { + } else { if (my_chsize(tmpfd, len) < 0) result = 0; PerlLIO_close(tmpfd); @@ -2269,13 +2308,13 @@ PP(pp_ioctl) dVAR; dSP; dTARGET; SV * const argsv = POPs; const unsigned int func = POPu; - const int optype = PL_op->op_type; + int optype; GV * const gv = MUTABLE_GV(POPs); - IO * const io = gv ? GvIOn(gv) : NULL; + IO * const io = GvIOn(gv); char *s; IV retval; - if (!io || !argsv || !IoIFP(io)) { + if (!IoIFP(io)) { report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); /* well, sort of... */ RETPUSHUNDEF; @@ -2298,6 +2337,7 @@ PP(pp_ioctl) s = INT2PTR(char*,retval); /* ouch */ } + optype = PL_op->op_type; TAINT_PROPER(PL_op_desc[optype]); if (optype == OP_IOCTL) @@ -2376,24 +2416,18 @@ PP(pp_socket) const int type = POPi; const int domain = POPi; GV * const gv = MUTABLE_GV(POPs); - IO * const io = gv ? GvIOn(gv) : NULL; + IO * const io = GvIOn(gv); int fd; - if (!io) { - report_evil_fh(gv); - if (io && IoIFP(io)) - do_close(gv, FALSE); - SETERRNO(EBADF,LIB_INVARG); - RETPUSHUNDEF; - } - if (IoIFP(io)) do_close(gv, FALSE); TAINT_PROPER("socket"); fd = PerlSock_socket(domain, type, protocol); - if (fd < 0) + if (fd < 0) { + SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; + } IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */ IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE); IoTYPE(io) = IoTYPE_SOCKET; @@ -2404,7 +2438,8 @@ PP(pp_socket) RETPUSHUNDEF; } #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ + if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */ + RETPUSHUNDEF; #endif RETPUSHYES; @@ -2415,28 +2450,21 @@ PP(pp_sockpair) { #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET)) dVAR; dSP; + int fd[2]; const int protocol = POPi; const int type = POPi; const int domain = POPi; + GV * const gv2 = MUTABLE_GV(POPs); + IO * const io2 = GvIOn(gv2); GV * const gv1 = MUTABLE_GV(POPs); - IO * const io1 = gv1 ? GvIOn(gv1) : NULL; - IO * const io2 = gv2 ? GvIOn(gv2) : NULL; - int fd[2]; + IO * const io1 = GvIOn(gv1); - if (!io1) - report_evil_fh(gv1); - if (!io2) - report_evil_fh(gv2); - - if (io1 && IoIFP(io1)) + if (IoIFP(io1)) do_close(gv1, FALSE); - if (io2 && IoIFP(io2)) + if (IoIFP(io2)) do_close(gv2, FALSE); - if (!io1 || !io2) - RETPUSHUNDEF; - TAINT_PROPER("socketpair"); if (PerlSock_socketpair(domain, type, protocol, fd) < 0) RETPUSHUNDEF; @@ -2456,8 +2484,10 @@ PP(pp_sockpair) RETPUSHUNDEF; } #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */ - fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */ + /* ensure close-on-exec */ + if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) || + (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0)) + RETPUSHUNDEF; #endif RETPUSHYES; @@ -2477,16 +2507,21 @@ PP(pp_bind) GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); STRLEN len; - const int op_type = PL_op->op_type; + int op_type; + int fd; - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; + fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) + goto nuts; addr = SvPV_const(addrsv, len); + op_type = PL_op->op_type; TAINT_PROPER(PL_op_desc[op_type]); if ((op_type == OP_BIND - ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) - : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)) + ? PerlSock_bind(fd, (struct sockaddr *)addr, len) + : PerlSock_connect(fd, (struct sockaddr *)addr, len)) >= 0) RETPUSHYES; else @@ -2503,9 +2538,9 @@ PP(pp_listen) dVAR; dSP; const int backlog = POPi; GV * const gv = MUTABLE_GV(POPs); - IO * const io = gv ? GvIOn(gv) : NULL; + IO * const io = GvIOn(gv); - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0) @@ -2523,7 +2558,6 @@ PP(pp_accept) { dVAR; dSP; dTARGET; IO *nstio; - IO *gstio; char namebuf[MAXPATHLEN]; #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__) Sock_size_t len = sizeof (struct sockaddr_in); @@ -2534,12 +2568,7 @@ PP(pp_accept) GV * const ngv = MUTABLE_GV(POPs); int fd; - if (!ngv) - goto badexit; - if (!ggv) - goto nuts; - - gstio = GvIO(ggv); + IO * const gstio = GvIO(ggv); if (!gstio || !IoIFP(gstio)) goto nuts; @@ -2570,7 +2599,8 @@ PP(pp_accept) goto badexit; } #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ + if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */ + goto badexit; #endif #ifdef __SCO_VERSION__ @@ -2596,7 +2626,7 @@ PP(pp_shutdown) GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 ); @@ -2620,10 +2650,12 @@ PP(pp_ssockopt) int fd; Sock_size_t len; - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) + goto nuts; switch (optype) { case OP_GSOCKOPT: SvGROW(sv, 257); @@ -2690,7 +2722,7 @@ PP(pp_getpeername) SV *sv; int fd; - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; sv = sv_2mortal(newSV(257)); @@ -2699,6 +2731,8 @@ PP(pp_getpeername) SvCUR_set(sv, len); *SvEND(sv) ='\0'; fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) + goto nuts; switch (optype) { case OP_GETSOCKNAME: if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0) @@ -2780,9 +2814,14 @@ PP(pp_stat) } if (io) { if (IoIFP(io)) { - PL_laststatval = - PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache); - havefp = TRUE; + int fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) { + 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); @@ -2800,6 +2839,7 @@ PP(pp_stat) } } else { + const char *file; if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { io = MUTABLE_IO(SvRV(sv)); if (PL_op->op_type == OP_LSTAT) @@ -2811,13 +2851,18 @@ PP(pp_stat) sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv)); PL_statgv = NULL; PL_laststype = PL_op->op_type; + file = SvPV_nolen_const(PL_statname); if (PL_op->op_type == OP_LSTAT) - PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache); + PL_laststatval = PerlLIO_lstat(file, &PL_statcache); else - PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache); + PL_laststatval = PerlLIO_stat(file, &PL_statcache); if (PL_laststatval < 0) { - if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n')) + if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { + /* PL_warn_nl is constant */ + GCC_DIAG_IGNORE(-Wformat-nonliteral); Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); + GCC_DIAG_RESTORE; + } max = 0; } } @@ -3020,7 +3065,7 @@ PP(pp_ftrread) access_mode = W_OK; #endif stat_mode = S_IWUSR; - /* fall through */ + /* FALLTHROUGH */ case OP_FTEREAD: #ifndef PERL_EFF_ACCESS @@ -3266,9 +3311,13 @@ PP(pp_fttty) if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); else if (name && isDIGIT(*name)) - fd = atoi(name); + fd = atoi(name); else FT_RETURNUNDEF; + if (fd < 0) { + SETERRNO(EBADF,RMS_IFI); + FT_RETURNUNDEF; + } if (PerlLIO_isatty(fd)) FT_RETURNYES; FT_RETURNNO; @@ -3278,7 +3327,7 @@ PP(pp_fttext) { dVAR; I32 i; - I32 len; + SSize_t len; I32 odd = 0; STDCHAR tbuf[512]; STDCHAR *s; @@ -3317,9 +3366,15 @@ PP(pp_fttext) PL_laststatval = -1; PL_laststype = OP_STAT; if (io && IoIFP(io)) { + int fd; 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); + fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) { + SETERRNO(EBADF,RMS_IFI); + FT_RETURNUNDEF; + } + PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); if (PL_laststatval < 0) FT_RETURNUNDEF; if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */ @@ -3332,9 +3387,10 @@ PP(pp_fttext) i = PerlIO_getc(IoIFP(io)); if (i != EOF) (void)PerlIO_ungetc(IoIFP(io),i); + else + /* null file is anything */ + FT_RETURNYES; } - if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */ - FT_RETURNYES; len = PerlIO_get_bufsiz(IoIFP(io)); s = (STDCHAR *) PerlIO_get_base(IoIFP(io)); /* sfio can have large buffers - limit to 512 */ @@ -3349,23 +3405,38 @@ PP(pp_fttext) } } else { + const char *file; + int fd; + + assert(sv); sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv)); really_filename: + file = SvPVX_const(PL_statname); PL_statgv = NULL; - if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) { + if (!(fp = PerlIO_open(file, "r"))) { if (!gv) { PL_laststatval = -1; PL_laststype = OP_STAT; } - if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), - '\n')) + if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { + /* PL_warn_nl is constant */ + GCC_DIAG_IGNORE(-Wformat-nonliteral); Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); + GCC_DIAG_RESTORE; + } FT_RETURNUNDEF; } PL_laststype = OP_STAT; - PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache); + fd = PerlIO_fileno(fp); + if (fd < 0) { + (void)PerlIO_close(fp); + SETERRNO(EBADF,RMS_IFI); + FT_RETURNUNDEF; + } + PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); if (PL_laststatval < 0) { (void)PerlIO_close(fp); + SETERRNO(EBADF,RMS_IFI); FT_RETURNUNDEF; } PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL); @@ -3480,19 +3551,19 @@ PP(pp_chdir) if (IoDIRP(io)) { PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0); } else if (IoIFP(io)) { - PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0); + int fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) { + goto nuts; + } + PUSHi(fchdir(fd) >= 0); } else { - report_evil_fh(gv); - SETERRNO(EBADF, RMS_IFI); - PUSHi(0); + goto nuts; } + } else { + goto nuts; } - else { - report_evil_fh(gv); - SETERRNO(EBADF,RMS_IFI); - PUSHi(0); - } + #else DIE(aTHX_ PL_no_func, "fchdir"); #endif @@ -3505,6 +3576,12 @@ PP(pp_chdir) hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD); #endif RETURN; + + nuts: + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); + PUSHi(0); + RETURN; } PP(pp_chown) @@ -3614,9 +3691,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 +3743,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)) { @@ -3796,9 +3865,6 @@ PP(pp_open_dir) GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io) - goto nope; - if ((IoIFP(io) || IoOFP(io))) Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), "Opening filehandle %"HEKf" also as a directory", @@ -3835,7 +3901,7 @@ PP(pp_readdir) const Direntry_t *dp; IO * const io = GvIOn(gv); - if (!io || !IoDIRP(io)) { + if (!IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), "readdir() attempted on invalid dirhandle %"HEKf, HEKfARG(GvENAME_HEK(gv))); @@ -3851,15 +3917,13 @@ 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); if (!dp && gimme != G_ARRAY) - goto nope; + RETPUSHUNDEF; RETURN; @@ -3887,7 +3951,7 @@ PP(pp_telldir) GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io || !IoDIRP(io)) { + if (!IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), "telldir() attempted on invalid dirhandle %"HEKf, HEKfARG(GvENAME_HEK(gv))); @@ -3913,7 +3977,7 @@ PP(pp_seekdir) GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io || !IoDIRP(io)) { + if (!IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), "seekdir() attempted on invalid dirhandle %"HEKf, HEKfARG(GvENAME_HEK(gv))); @@ -3938,7 +4002,7 @@ PP(pp_rewinddir) GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io || !IoDIRP(io)) { + if (!IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), "rewinddir() attempted on invalid dirhandle %"HEKf, HEKfARG(GvENAME_HEK(gv))); @@ -3962,7 +4026,7 @@ PP(pp_closedir) GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io || !IoDIRP(io)) { + if (!IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), "closedir() attempted on invalid dirhandle %"HEKf, HEKfARG(GvENAME_HEK(gv))); @@ -3995,13 +4059,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 +4077,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 +4196,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 +4216,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,13 +4270,14 @@ 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) { PerlLIO_close(pp[0]); #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(pp[1], F_SETFD, FD_CLOEXEC); + if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0) + RETPUSHUNDEF; #endif } if (PL_op->op_flags & OPf_STACKED) { @@ -4414,20 +4479,16 @@ PP(pp_tms) #ifdef HAS_TIMES dVAR; dSP; + struct tms timesbuf; + EXTEND(SP, 4); -#ifndef VMS - (void)PerlProc_times(&PL_timesbuf); -#else - (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */ - /* struct tms, though same data */ - /* is returned. */ -#endif + (void)PerlProc_times(×buf); - mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick); + mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick); if (GIMME == G_ARRAY) { - mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick); - mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick); - mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick); + mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick); + mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick); + mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick); } RETURN; #else @@ -4505,30 +4566,29 @@ PP(pp_gmtime) } if (err == NULL) { + /* diag_listed_as: gmtime(%f) failed */ /* XXX %lld broken for quads */ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), "%s(%.0" NVff ") failed", opname, when); } if (GIMME != G_ARRAY) { /* scalar context */ - SV *tsv; - /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */ - double year = (double)tmbuf.tm_year + 1900; - EXTEND(SP, 1); EXTEND_MORTAL(1); if (err == NULL) RETPUSHUNDEF; - - tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f", - dayname[tmbuf.tm_wday], - monname[tmbuf.tm_mon], - tmbuf.tm_mday, - tmbuf.tm_hour, - tmbuf.tm_min, - tmbuf.tm_sec, - year); - mPUSHs(tsv); + else { + mPUSHs(Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f", + dayname[tmbuf.tm_wday], + monname[tmbuf.tm_mon], + tmbuf.tm_mday, + tmbuf.tm_hour, + tmbuf.tm_min, + tmbuf.tm_sec, + /* XXX newSVpvf()'s %lld type is broken, + * so cheat with a double */ + (double)tmbuf.tm_year + 1900)); + } } else { /* list context */ if ( err == NULL ) @@ -5220,11 +5280,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 +5325,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);