X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/42409c4069deb2417b838a49810ecbce306a72b9..66786896871dad5f544c0dd64c351a09ca3e612e:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index a17227d4..a97b040 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -179,10 +179,6 @@ static const char zero_but_true[ZBTLEN + 1] = "0 but true"; # include #endif -#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC) -# define FD_CLOEXEC 1 /* NeXT needs this */ -#endif - #include "reentr.h" #ifdef __Lynx__ @@ -295,7 +291,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) PP(pp_backtick) { - dVAR; dSP; dTARGET; + dSP; dTARGET; PerlIO *fp; const char * const tmps = POPpconstx; const I32 gimme = GIMME_V; @@ -356,26 +352,26 @@ PP(pp_backtick) PP(pp_glob) { - dVAR; OP *result; dSP; + GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs; + + PUTBACK; + /* 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)); + if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs)); - tryAMAGICunTARGETlist(iter_amg, -1, (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: - * MARK, wildcard, csh_glob context index + * MARK, wildcard * and following OPs should be: gv(CORE::GLOBAL::glob), entersub * */ return NORMAL; } - /* stack args are: wildcard, gv(_GEN_n) */ - if (PL_globhook) { - SETs(GvSV(TOPs)); PL_globhook(aTHX); return NORMAL; } @@ -387,7 +383,7 @@ PP(pp_glob) ENTER_with_name("glob"); #ifndef VMS - if (PL_tainting) { + if (TAINTING_get) { /* * The external globbing program may use things we can't control, * so for security reasons we must assume the worst. @@ -398,7 +394,7 @@ PP(pp_glob) #endif /* !VMS */ SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */ - PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); + PL_last_in_gv = gv; SAVESPTR(PL_rs); /* This is not permanent, either. */ PL_rs = newSVpvs_flags("\000", SVs_TEMP); @@ -415,14 +411,13 @@ PP(pp_glob) PP(pp_rcatline) { - dVAR; PL_last_in_gv = cGVOP_gv; return do_readline(); } PP(pp_warn) { - dVAR; dSP; dMARK; + dSP; dMARK; SV *exsv; STRLEN len; if (SP - MARK > 1) { @@ -445,17 +440,18 @@ PP(pp_warn) /* well-formed exception supplied */ } else { - SvGETMAGIC(ERRSV); - if (SvROK(ERRSV)) { - if (SvGMAGICAL(ERRSV)) { + SV * const errsv = ERRSV; + SvGETMAGIC(errsv); + if (SvROK(errsv)) { + if (SvGMAGICAL(errsv)) { exsv = sv_newmortal(); - sv_setsv_nomg(exsv, ERRSV); + sv_setsv_nomg(exsv, errsv); } - else exsv = ERRSV; + else exsv = errsv; } - else if (SvPOKp(ERRSV) ? SvCUR(ERRSV) : SvNIOKp(ERRSV)) { + else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) { exsv = sv_newmortal(); - sv_setsv_nomg(exsv, ERRSV); + sv_setsv_nomg(exsv, errsv); sv_catpvs(exsv, "\t...caught"); } else { @@ -470,11 +466,12 @@ PP(pp_warn) PP(pp_die) { - dVAR; dSP; dMARK; + dSP; dMARK; 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; @@ -489,40 +486,46 @@ PP(pp_die) if (SvROK(exsv) || (SvPV_const(exsv, len), len)) { /* well-formed exception supplied */ } - else if (SvROK(ERRSV)) { - exsv = ERRSV; - if (sv_isobject(exsv)) { - HV * const stash = SvSTASH(SvRV(exsv)); - GV * const gv = gv_fetchmethod(stash, "PROPAGATE"); - if (gv) { - SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0)); - SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop))); - EXTEND(SP, 3); - PUSHMARK(SP); - PUSHs(exsv); - PUSHs(file); - PUSHs(line); - PUTBACK; - call_sv(MUTABLE_SV(GvCV(gv)), - G_SCALAR|G_EVAL|G_KEEPERR); - exsv = sv_mortalcopy(*PL_stack_sp--); + else { + SV * const errsv = ERRSV; + SvGETMAGIC(errsv); + if (SvROK(errsv)) { + exsv = errsv; + if (sv_isobject(exsv)) { + HV * const stash = SvSTASH(SvRV(exsv)); + GV * const gv = gv_fetchmethod(stash, "PROPAGATE"); + if (gv) { + SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0)); + SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop))); + EXTEND(SP, 3); + PUSHMARK(SP); + PUSHs(exsv); + PUSHs(file); + PUSHs(line); + PUTBACK; + call_sv(MUTABLE_SV(GvCV(gv)), + G_SCALAR|G_EVAL|G_KEEPERR); + exsv = sv_mortalcopy(*PL_stack_sp--); + } } } + else if (SvPOK(errsv) && SvCUR(errsv)) { + exsv = sv_mortalcopy(errsv); + sv_catpvs(exsv, "\t...propagated"); + } + else { + exsv = newSVpvs_flags("Died", SVs_TEMP); + } } - else if (SvPV_const(ERRSV, len), len) { - exsv = sv_mortalcopy(ERRSV); - sv_catpvs(exsv, "\t...propagated"); - } - else { - exsv = newSVpvs_flags("Died", SVs_TEMP); - } - return die_sv(exsv); + die_sv(exsv); + NOT_REACHED; /* NOTREACHED */ + return NULL; /* avoid missing return from non-void function warning */ } /* 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; @@ -566,7 +569,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; @@ -590,7 +593,7 @@ Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv, PP(pp_open) { - dVAR; dSP; + dSP; dMARK; dORIGMARK; dTARGET; SV *sv; @@ -617,7 +620,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); } @@ -631,7 +634,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 ); @@ -644,7 +647,7 @@ PP(pp_open) PP(pp_close) { - dVAR; dSP; + dSP; GV * const gv = MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs); @@ -656,7 +659,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); } } } @@ -667,25 +670,21 @@ PP(pp_close) PP(pp_pipe_op) { #ifdef HAS_PIPE - dVAR; dSP; - register IO *rstio; - register IO *wstio; + IO *rstio; + IO *wstio; int fd[2]; 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); @@ -711,8 +710,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; @@ -725,7 +726,7 @@ badexit: PP(pp_fileno) { - dVAR; dSP; dTARGET; + dSP; dTARGET; GV *gv; IO *io; PerlIO *fp; @@ -739,7 +740,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))) { @@ -757,7 +758,6 @@ PP(pp_fileno) PP(pp_umask) { - dVAR; dSP; #ifdef HAS_UMASK dTARGET; @@ -788,7 +788,7 @@ PP(pp_umask) PP(pp_binmode) { - dVAR; dSP; + dSP; GV *gv; IO *io; PerlIO *fp; @@ -810,7 +810,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); } @@ -849,7 +849,7 @@ PP(pp_binmode) PP(pp_tie) { - dVAR; dSP; dMARK; + dSP; dMARK; HV* stash; GV *gv = NULL; SV *sv; @@ -861,9 +861,16 @@ PP(pp_tie) switch(SvTYPE(varsv)) { case SVt_PVHV: + { + HE *entry; methname = "TIEHASH"; + if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) { + HvLAZYDEL_off(varsv); + hv_free_ent((HV *)varsv, entry); + } HvEITER_set(MUTABLE_HV(varsv), 0); break; + } case SVt_PVAV: methname = "TIEARRAY"; if (!AvREAL(varsv)) { @@ -886,7 +893,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; @@ -945,7 +956,7 @@ PP(pp_tie) PP(pp_untie) { - dVAR; dSP; + dSP; MAGIC *mg; SV *sv = POPs; const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) @@ -954,6 +965,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) { @@ -982,26 +996,30 @@ PP(pp_untie) 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) { - dVAR; dSP; + dSP; dPOPPOPssrl; HV* stash; GV *gv = NULL; @@ -1058,11 +1076,11 @@ PP(pp_dbmopen) PP(pp_sselect) { #ifdef HAS_SELECT - dVAR; dSP; dTARGET; - register I32 i; - register I32 j; - register char *s; - register SV *sv; + dSP; dTARGET; + I32 i; + I32 j; + char *s; + SV *sv; NV value; I32 maxlen = 0; I32 nfound; @@ -1090,11 +1108,10 @@ PP(pp_sselect) if (!SvOK(sv)) continue; if (SvREADONLY(sv)) { - if (SvIsCOW(sv)) - sv_force_normal_flags(sv, 0); - if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0)) - Perl_croak_no_modify(aTHX); + 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), @@ -1131,14 +1148,15 @@ PP(pp_sselect) /* If SELECT_MIN_BITS is greater than one we most probably will want * to align the sizes with SELECT_MIN_BITS/8 because for example * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital - * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates + * UNIX, Solaris, Darwin) the smallest quantum select() operates * on (sets/tests/clears bits) is 32 bits. */ growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8))); # 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; @@ -1222,10 +1240,13 @@ PP(pp_sselect) } /* + +=head1 GV Functions + =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. @@ -1235,7 +1256,6 @@ of the typeglob that PL_defoutgv points to is decreased by one. void Perl_setdefout(pTHX_ GV *gv) { - dVAR; PERL_ARGS_ASSERT_SETDEFOUT; SvREFCNT_inc_simple_void_NN(gv); SvREFCNT_dec(PL_defoutgv); @@ -1244,7 +1264,7 @@ Perl_setdefout(pTHX_ GV *gv) PP(pp_select) { - dVAR; dSP; dTARGET; + dSP; dTARGET; HV *hv; GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL; GV * egv = GvEGVx(PL_defoutgv); @@ -1275,7 +1295,7 @@ PP(pp_select) PP(pp_getc) { - dVAR; dSP; dTARGET; + dSP; dTARGET; GV * const gv = MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs); IO *const io = GvIO(gv); @@ -1287,7 +1307,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); @@ -1314,6 +1334,7 @@ PP(pp_getc) } SvUTF8_on(TARG); } + else SvUTF8_off(TARG); PUSHTARG; RETURN; } @@ -1321,13 +1342,12 @@ PP(pp_getc) STATIC OP * S_doform(pTHX_ CV *cv, GV *gv, OP *retop) { - dVAR; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; const I32 gimme = GIMME_V; PERL_ARGS_ASSERT_DOFORM; - if (cv && CvCLONE(cv)) + if (CvCLONE(cv)) cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); ENTER; @@ -1335,8 +1355,12 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp); PUSHFORMAT(cx, retop); + if (CvDEPTH(cv) >= 2) { + PERL_STACK_OVERFLOW_CHECK(); + pad_push(CvPADLIST(cv), CvDEPTH(cv)); + } SAVECOMPPAD(); - PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); + PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv)); setdefout(gv); /* locally select filehandle so $% et al work */ return CvSTART(cv); @@ -1344,17 +1368,16 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) PP(pp_enterwrite) { - dVAR; dSP; - register GV *gv; - register IO *io; + GV *gv; + IO *io; GV *fgv; CV *cv = NULL; SV *tmpsv = NULL; if (MAXARG == 0) { - gv = PL_defoutgv; EXTEND(SP, 1); + gv = PL_defoutgv; } else { gv = MUTABLE_GV(POPs); @@ -1384,22 +1407,16 @@ PP(pp_enterwrite) PP(pp_leavewrite) { - dVAR; dSP; + dSP; GV * const gv = cxstack[cxstack_ix].blk_format.gv; - register IO * const io = GvIOp(gv); + IO * const io = GvIOp(gv); PerlIO *ofp; PerlIO *fp; SV **newsp; I32 gimme; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; OP *retop; - /* I'm not sure why, but executing the format leaves an extra value on the - * stack. There's probably a better place to be handling this (probably - * by avoiding pushing it in the first place!) but I don't quite know - * where to look. -doy */ - (void)POPs; - if (!io || !(ofp = IoOFP(io))) goto forget_top; @@ -1455,32 +1472,31 @@ PP(pp_leavewrite) } } if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0) - do_print(PL_formfeed, ofp); + do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp); IoLINES_LEFT(io) = IoPAGE_LEN(io); IoPAGE(io)++; 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(); gv_efullname4(sv, fgv, NULL, FALSE); DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv)); } - RETURNOP(doform(cv, gv, PL_op)); + return doform(cv, gv, PL_op); } forget_top: POPBLOCK(cx,PL_curpm); - POPFORMAT(cx); retop = cx->blk_sub.retop; + POPFORMAT(cx); + SP = newsp; /* ignore retval of formline */ LEAVE; - fp = IoOFP(io); - if (!fp) { - if (IoIFP(io)) + if (!io || !(fp = IoOFP(io))) { + if (io && IoIFP(io)) report_wrongway_fh(gv, '<'); else report_evil_fh(gv); @@ -1501,23 +1517,23 @@ PP(pp_leavewrite) PUSHs(&PL_sv_yes); } } - /* bad_ofp: */ PL_formtarget = PL_bodytarget; - PERL_UNUSED_VAR(newsp); PERL_UNUSED_VAR(gimme); RETURNOP(retop); } PP(pp_prtf) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; PerlIO *fp; - SV *sv; GV * const gv = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv; IO *const io = GvIO(gv); + /* Treat empty list as "" */ + if (MARK == SP) XPUSHs(&PL_sv_no); + if (io) { const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { @@ -1527,14 +1543,13 @@ 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); } } - sv = newSV(0); if (!io) { report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); @@ -1549,6 +1564,7 @@ PP(pp_prtf) goto just_say_no; } else { + SV *sv = sv_newmortal(); do_sprintf(sv, SP - MARK, MARK + 1); if (!do_print(sv, fp)) goto just_say_no; @@ -1557,13 +1573,11 @@ PP(pp_prtf) if (PerlIO_flush(fp) == EOF) goto just_say_no; } - SvREFCNT_dec(sv); SP = ORIGMARK; PUSHs(&PL_sv_yes); RETURN; just_say_no: - SvREFCNT_dec(sv); SP = ORIGMARK; PUSHs(&PL_sv_undef); RETURN; @@ -1571,7 +1585,6 @@ PP(pp_prtf) PP(pp_sysopen) { - dVAR; dSP; const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666; const int mode = POPi; @@ -1581,8 +1594,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); } @@ -1594,7 +1606,7 @@ PP(pp_sysopen) PP(pp_sysread) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; SSize_t offset; IO *io; char *buffer; @@ -1611,14 +1623,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); } @@ -1643,6 +1656,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 */ @@ -1654,12 +1671,7 @@ PP(pp_sysread) buffer_utf8 = !IN_BYTES && SvUTF8(bufsv); } if (DO_UTF8(bufsv)) { - /* offset adjust in characters not bytes */ - /* SV's length cache is only safe for non-magical values */ - if (SvGMAGICAL(bufsv)) - blen = utf8_length((const U8 *)buffer, (const U8 *)buffer + blen); - else - blen = sv_len_utf8(bufsv); + blen = sv_len_utf8_nomg(bufsv); } charstart = TRUE; @@ -1671,7 +1683,11 @@ PP(pp_sysread) if (PL_op->op_type == OP_RECV) { Sock_size_t bufsize; char namebuf[MAXPATHLEN]; -#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__) + if (fd < 0) { + SETERRNO(EBADF,SS_IVCHAN); + RETPUSHUNDEF; + } +#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__) bufsize = sizeof (struct sockaddr_in); #else bufsize = sizeof namebuf; @@ -1682,17 +1698,13 @@ 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; /* MSG_TRUNC can give oversized count; quietly lose it */ if (count > length) count = length; -#ifdef EPOC - /* Bogus return without padding */ - bufsize = sizeof (struct sockaddr_in); -#endif SvCUR_set(bufsv, count); *SvEND(bufsv) = '\0'; (void)SvPOK_only(bufsv); @@ -1703,6 +1715,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; @@ -1720,7 +1740,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 @@ -1750,31 +1774,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 */ @@ -1844,7 +1862,7 @@ PP(pp_sysread) PP(pp_syswrite) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; SV *bufsv; const char *buffer; SSize_t retval; @@ -1855,6 +1873,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); @@ -1865,7 +1884,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); } @@ -1885,6 +1904,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); @@ -1919,12 +1944,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 @@ -1940,15 +1964,9 @@ PP(pp_syswrite) blen_chars = orig_blen_bytes; } else { /* The SV really is UTF-8. */ - if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) { - /* Don't call sv_len_utf8 again because it will call magic - or overloading a second time, and we might get back a - different result. */ - blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen); - } else { - /* It's safe, and it may well be cached. */ - blen_chars = sv_len_utf8(bufsv); - } + /* 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; @@ -2013,15 +2031,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); } } @@ -2047,7 +2063,7 @@ PP(pp_syswrite) PP(pp_eof) { - dVAR; dSP; + dSP; GV *gv; IO *io; const MAGIC *mg; @@ -2084,15 +2100,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 @@ -2110,7 +2126,7 @@ PP(pp_eof) PP(pp_tell) { - dVAR; dSP; dTARGET; + dSP; dTARGET; GV *gv; IO *io; @@ -2124,7 +2140,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) { @@ -2144,7 +2160,7 @@ PP(pp_tell) PP(pp_sysseek) { - dVAR; dSP; + dSP; const int whence = POPi; #if LSEEKSIZE > IVSIZE const Off_t offset = (Off_t)SvNVx(POPs); @@ -2164,7 +2180,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)); } } @@ -2191,7 +2207,6 @@ PP(pp_sysseek) PP(pp_truncate) { - dVAR; dSP; /* There seems to be no consensus on the length type of truncate() * and ftruncate(), both off_t and size_t have supporters. In @@ -2229,13 +2244,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; + } } } } @@ -2253,9 +2274,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); @@ -2274,16 +2296,16 @@ PP(pp_truncate) PP(pp_ioctl) { - dVAR; dSP; dTARGET; + 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; @@ -2306,6 +2328,7 @@ PP(pp_ioctl) s = INT2PTR(char*,retval); /* ouch */ } + optype = PL_op->op_type; TAINT_PROPER(PL_op_desc[optype]); if (optype == OP_IOCTL) @@ -2349,7 +2372,7 @@ PP(pp_ioctl) PP(pp_flock) { #ifdef FLOCK - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 value; const int argtype = POPi; GV * const gv = MUTABLE_GV(POPs); @@ -2369,7 +2392,7 @@ PP(pp_flock) PUSHi(value); RETURN; #else - DIE(aTHX_ PL_no_func, "flock()"); + DIE(aTHX_ PL_no_func, "flock"); #endif } @@ -2379,29 +2402,23 @@ PP(pp_flock) PP(pp_socket) { - dVAR; dSP; + dSP; const int protocol = POPi; const int type = POPi; const int domain = POPi; GV * const gv = MUTABLE_GV(POPs); - register 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; @@ -2412,11 +2429,8 @@ PP(pp_socket) RETPUSHUNDEF; } #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ -#endif - -#ifdef EPOC - setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */ + if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */ + RETPUSHUNDEF; #endif RETPUSHYES; @@ -2426,29 +2440,22 @@ PP(pp_socket) PP(pp_sockpair) { #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET)) - dVAR; dSP; + 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); - register IO * const io1 = gv1 ? GvIOn(gv1) : NULL; - register IO * const io2 = gv2 ? GvIOn(gv2) : NULL; - int fd[2]; - - if (!io1) - report_evil_fh(gv1); - if (!io2) - report_evil_fh(gv2); + IO * const io1 = GvIOn(gv1); - 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; @@ -2468,8 +2475,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; @@ -2482,23 +2491,28 @@ PP(pp_sockpair) PP(pp_bind) { - dVAR; dSP; + dSP; SV * const addrsv = POPs; /* OK, so on what platform does bind modify addr? */ const char *addr; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + 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 @@ -2512,12 +2526,12 @@ nuts: PP(pp_listen) { - dVAR; dSP; + dSP; const int backlog = POPi; GV * const gv = MUTABLE_GV(POPs); - register 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) @@ -2533,11 +2547,10 @@ nuts: PP(pp_accept) { - dVAR; dSP; dTARGET; - register IO *nstio; - register IO *gstio; + dSP; dTARGET; + IO *nstio; char namebuf[MAXPATHLEN]; -#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__) +#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__) Sock_size_t len = sizeof (struct sockaddr_in); #else Sock_size_t len = sizeof namebuf; @@ -2546,12 +2559,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; @@ -2582,13 +2590,10 @@ 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 EPOC - len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */ - setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */ -#endif #ifdef __SCO_VERSION__ len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */ #endif @@ -2607,12 +2612,12 @@ badexit: PP(pp_shutdown) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const int how = POPi; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + IO * const io = GvIOn(gv); - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 ); @@ -2626,20 +2631,22 @@ nuts: PP(pp_ssockopt) { - dVAR; dSP; + dSP; const int optype = PL_op->op_type; SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs; const unsigned int optname = (unsigned int) POPi; const unsigned int lvl = (unsigned int) POPi; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + IO * const io = GvIOn(gv); 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); @@ -2698,15 +2705,15 @@ nuts2: PP(pp_getpeername) { - dVAR; dSP; + dSP; const int optype = PL_op->op_type; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + IO * const io = GvIOn(gv); Sock_size_t len; SV *sv; int fd; - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; sv = sv_2mortal(newSV(257)); @@ -2715,6 +2722,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) @@ -2760,7 +2769,6 @@ nuts2: PP(pp_stat) { - dVAR; dSP; GV *gv = NULL; IO *io = NULL; @@ -2796,9 +2804,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); @@ -2816,6 +2829,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) @@ -2827,13 +2841,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; } } @@ -2859,24 +2878,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 @@ -2907,6 +2912,13 @@ PP(pp_stat) RETURN; } +/* All filetest ops avoid manipulating the perl stack pointer in their main + bodies (since commit d2c4d2d1e22d3125), and return using either + S_ft_return_false() or S_ft_return_true(). These two helper functions are + the only two which manipulate the perl stack. To ensure that no stack + manipulation macros are used, the filetest ops avoid defining a local copy + of the stack pointer with dSP. */ + /* If the next filetest is stacked up with this one (PL_op->op_private & OPpFT_STACKING), we leave the original argument on the stack for success, @@ -2915,39 +2927,39 @@ PP(pp_stat) */ static OP * -S_ft_stacking_return_false(pTHX_ SV *ret) { - dSP; +S_ft_return_false(pTHX_ SV *ret) { OP *next = NORMAL; - while (OP_IS_FILETEST(next->op_type) - && next->op_private & OPpFT_STACKED) - next = next->op_next; + dSP; + if (PL_op->op_flags & OPf_REF) XPUSHs(ret); else SETs(ret); PUTBACK; + + if (PL_op->op_private & OPpFT_STACKING) { + while (OP_IS_FILETEST(next->op_type) + && next->op_private & OPpFT_STACKED) + next = next->op_next; + } return next; } -#define FT_RETURN_FALSE(X) \ - STMT_START { \ - if (PL_op->op_private & OPpFT_STACKING) \ - return S_ft_stacking_return_false(aTHX_ X); \ - RETURNX(PL_op->op_flags & OPf_REF ? XPUSHs(X) : SETs(X)); \ - } STMT_END -#define FT_RETURN_TRUE(X) \ - RETURNX((void)( \ - PL_op->op_flags & OPf_REF \ - ? (bool)XPUSHs( \ - PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (X) \ - ) \ - : (PL_op->op_private & OPpFT_STACKING || SETs(X)) \ - )) - -#define FT_RETURNNO FT_RETURN_FALSE(&PL_sv_no) -#define FT_RETURNUNDEF FT_RETURN_FALSE(&PL_sv_undef) -#define FT_RETURNYES FT_RETURN_TRUE(&PL_sv_yes) +PERL_STATIC_INLINE OP * +S_ft_return_true(pTHX_ SV *ret) { + dSP; + if (PL_op->op_flags & OPf_REF) + XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret)); + else if (!(PL_op->op_private & OPpFT_STACKING)) + SETs(ret); + PUTBACK; + return NORMAL; +} + +#define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no) +#define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef) +#define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes) #define tryAMAGICftest_MG(chr) STMT_START { \ - if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \ + if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \ && PL_op->op_flags & OPf_KIDS) { \ OP *next = S_try_amagic_ftest(aTHX_ chr); \ if (next) return next; \ @@ -2956,14 +2968,12 @@ S_ft_stacking_return_false(pTHX_ SV *ret) { STATIC OP * S_try_amagic_ftest(pTHX_ char chr) { - dVAR; - dSP; - SV* const arg = TOPs; + SV *const arg = *PL_stack_sp; assert(chr != '?'); if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg); - if (SvAMAGIC(TOPs)) + if (SvAMAGIC(arg)) { const char tmpchr = chr; SV * const tmpsv = amagic_call(arg, @@ -2973,8 +2983,8 @@ S_try_amagic_ftest(pTHX_ char chr) { if (!tmpsv) return NULL; - if (SvTRUE(tmpsv)) FT_RETURN_TRUE(tmpsv); - FT_RETURN_FALSE(tmpsv); + return SvTRUE(tmpsv) + ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv); } return NULL; } @@ -2982,10 +2992,9 @@ S_try_amagic_ftest(pTHX_ char chr) { PP(pp_ftrread) { - dVAR; I32 result; /* Not const, because things tweak this below. Not bool, because there's - no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */ + no guarantee that OPpFT_ACCESS is <= CHAR_MAX */ #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) I32 use_access = PL_op->op_private & OPpFT_ACCESS; /* Giving some sort of initial value silences compilers. */ @@ -3003,7 +3012,6 @@ PP(pp_ftrread) bool effective = FALSE; char opchar = '?'; - dSP; switch (PL_op->op_type) { case OP_FTRREAD: opchar = 'R'; break; @@ -3045,7 +3053,7 @@ PP(pp_ftrread) access_mode = W_OK; #endif stat_mode = S_IWUSR; - /* fall through */ + /* FALLTHROUGH */ case OP_FTEREAD: #ifndef PERL_EFF_ACCESS @@ -3067,7 +3075,7 @@ PP(pp_ftrread) if (use_access) { #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) - const char *name = TOPpx; + const char *name = SvPV_nolen(*PL_stack_sp); if (effective) { # ifdef PERL_EFF_ACCESS result = PERL_EFF_ACCESS(name, access_mode); @@ -3101,11 +3109,9 @@ PP(pp_ftrread) PP(pp_ftis) { - dVAR; I32 result; const int op_type = PL_op->op_type; char opchar = '?'; - dSP; switch (op_type) { case OP_FTIS: opchar = 'e'; break; @@ -3147,17 +3153,15 @@ PP(pp_ftis) break; } SvSETMAGIC(TARG); - if (SvTRUE_nomg(TARG)) FT_RETURN_TRUE(TARG); - else FT_RETURN_FALSE(TARG); + return SvTRUE_nomg(TARG) + ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG); } } PP(pp_ftrowned) { - dVAR; I32 result; char opchar = '?'; - dSP; switch (PL_op->op_type) { case OP_FTROWNED: opchar = 'O'; break; @@ -3257,8 +3261,6 @@ PP(pp_ftrowned) PP(pp_ftlink) { - dVAR; - dSP; I32 result; tryAMAGICftest_MG('l'); @@ -3273,8 +3275,6 @@ PP(pp_ftlink) PP(pp_fttty) { - dVAR; - dSP; int fd; GV *gv; char *name = NULL; @@ -3285,7 +3285,7 @@ PP(pp_fttty) if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; else { - SV *tmpsv = TOPs; + SV *tmpsv = *PL_stack_sp; if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) { name = SvPV_nomg(tmpsv, namelen); gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO); @@ -3295,33 +3295,27 @@ PP(pp_fttty) if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); else if (name && isDIGIT(*name)) - fd = atoi(name); + fd = grok_atou(name, NULL); else FT_RETURNUNDEF; + if (fd < 0) { + SETERRNO(EBADF,RMS_IFI); + FT_RETURNUNDEF; + } if (PerlLIO_isatty(fd)) FT_RETURNYES; FT_RETURNNO; } -#if defined(atarist) /* this will work with atariST. Configure will - make guesses for other systems. */ -# define FILE_base(f) ((f)->_base) -# define FILE_ptr(f) ((f)->_ptr) -# define FILE_cnt(f) ((f)->_cnt) -# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base)) -#endif - PP(pp_fttext) { - dVAR; - dSP; I32 i; - I32 len; + SSize_t len; I32 odd = 0; STDCHAR tbuf[512]; - register STDCHAR *s; - register IO *io; - register SV *sv = NULL; + STDCHAR *s; + IO *io; + SV *sv = NULL; GV *gv; PerlIO *fp; @@ -3333,7 +3327,7 @@ PP(pp_fttext) == OPpFT_STACKED) gv = PL_defgv; else { - sv = TOPs; + sv = *PL_stack_sp; gv = MAYBE_DEREF_GV_nomg(sv); } @@ -3355,9 +3349,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 */ @@ -3370,9 +3370,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 */ @@ -3387,23 +3388,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); @@ -3418,7 +3434,6 @@ PP(pp_fttext) } /* now scan s to look for textiness */ - /* XXX ASCII dependent code */ #if defined(DOSISH) || defined(USEMYBINMODE) /* ignore trailing ^Z on short files */ @@ -3426,43 +3441,53 @@ PP(pp_fttext) --len; #endif + assert(len); + if (! is_ascii_string((U8 *) s, len)) { + const U8 *ep; + + /* Here contains a non-ASCII. See if the entire string is UTF-8. But + * the buffer may end in a partial character, so consider it UTF-8 if + * the first non-UTF8 char is an ending partial */ + if (is_utf8_string_loc((U8 *) s, len, &ep) + || ep + UTF8SKIP(ep) > (U8 *) (s + len)) + { + if (PL_op->op_type == OP_FTTEXT) { + FT_RETURNYES; + } + else { + FT_RETURNNO; + } + } + } + + /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for + * things that wouldn't be in ASCII text or rich ASCII text. Count these + * in 'odd' */ for (i = 0; i < len; i++, s++) { if (!*s) { /* null never allowed in text */ odd += len; break; } -#ifdef EBCDIC - else if (!(isPRINT(*s) || isSPACE(*s))) - odd++; -#else - else if (*s & 128) { -#ifdef USE_LOCALE - if (IN_LOCALE_RUNTIME && isALPHA_LC(*s)) +#ifdef USE_LOCALE_CTYPE + if (IN_LC_RUNTIME(LC_CTYPE)) { + if ( isPRINT_LC(*s) || isSPACE_LC(*s)) { continue; + } + } + else #endif - /* utf8 characters don't count as odd */ - if (UTF8_IS_START(*s)) { - int ulen = UTF8SKIP(s); - if (ulen < len - i) { - int j; - for (j = 1; j < ulen; j++) { - if (!UTF8_IS_CONTINUATION(s[j])) - goto not_utf8; - } - --ulen; /* loop does extra increment */ - s += ulen; - i += ulen; - continue; - } - } - not_utf8: - odd++; - } - else if (*s < 32 && - *s != '\n' && *s != '\r' && *s != '\b' && - *s != '\t' && *s != '\f' && *s != 27) - odd++; -#endif + if (isPRINT_A(*s) + /* VT occurs so rarely in text, that we consider it odd */ + || (isSPACE_A(*s) && *s != VT_NATIVE) + + /* But there is a fair amount of backspaces and escapes in + * some text */ + || *s == '\b' + || *s == ESC_NATIVE) + { + continue; + } + odd++; } if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */ @@ -3475,7 +3500,7 @@ PP(pp_fttext) PP(pp_chdir) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const char *tmps = NULL; GV *gv = NULL; @@ -3518,19 +3543,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 @@ -3543,11 +3568,17 @@ 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) { - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; const I32 value = (I32)apply(PL_op->op_type, MARK, SP); SP = MARK; @@ -3558,7 +3589,7 @@ PP(pp_chown) PP(pp_chroot) { #ifdef HAS_CHROOT - dVAR; dSP; dTARGET; + dSP; dTARGET; char * const tmps = POPpx; TAINT_PROPER("chroot"); PUSHi( chroot(tmps) >= 0 ); @@ -3570,7 +3601,7 @@ PP(pp_chroot) PP(pp_rename) { - dVAR; dSP; dTARGET; + dSP; dTARGET; int anum; const char * const tmps2 = POPpconstx; const char * const tmps = SvPV_nolen_const(TOPs); @@ -3596,7 +3627,7 @@ PP(pp_rename) #if defined(HAS_LINK) || defined(HAS_SYMLINK) PP(pp_link) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const int op_type = PL_op->op_type; int result; @@ -3644,21 +3675,22 @@ PP(pp_link) PP(pp_readlink) { - dVAR; dSP; #ifdef HAS_SYMLINK dTARGET; const char *tmps; char buf[MAXPATHLEN]; - int len; + SSize_t len; -#ifndef INCOMPLETE_TAINTS TAINT; -#endif tmps = POPpconstx; + /* NOTE: if the length returned by readlink() is sizeof(buf) - 1, + * it is impossible to know whether the result was truncated. */ len = readlink(tmps, buf, sizeof(buf) - 1); if (len < 0) RETPUSHUNDEF; + if (len != -1) + buf[len] = '\0'; PUSHp(buf, len); RETURN; #else @@ -3706,13 +3738,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)) { @@ -3780,7 +3806,7 @@ S_dooneliner(pTHX_ const char *cmd, const char *filename) PP(pp_mkdir) { - dVAR; dSP; dTARGET; + dSP; dTARGET; STRLEN len; const char *tmps; bool copy = FALSE; @@ -3807,7 +3833,7 @@ PP(pp_mkdir) PP(pp_rmdir) { - dVAR; dSP; dTARGET; + dSP; dTARGET; STRLEN len; const char *tmps; bool copy = FALSE; @@ -3829,13 +3855,10 @@ PP(pp_rmdir) PP(pp_open_dir) { #if defined(Direntry_t) && defined(HAS_READDIR) - dVAR; dSP; + dSP; const char * const dirname = POPpconstx; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); - - if (!io) - goto nope; + IO * const io = GvIOn(gv); if ((IoIFP(io) || IoOFP(io))) Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), @@ -3864,16 +3887,15 @@ PP(pp_readdir) #if !defined(I_DIRENT) && !defined(VMS) Direntry_t *readdir (DIR *); #endif - dVAR; dSP; SV *sv; const I32 gimme = GIMME; GV * const gv = MUTABLE_GV(POPs); - register const Direntry_t *dp; - register IO * const io = GvIOn(gv); + 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))); @@ -3889,15 +3911,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; @@ -3914,7 +3934,7 @@ nope: PP(pp_telldir) { #if defined(HAS_TELLDIR) || defined(telldir) - dVAR; dSP; dTARGET; + dSP; dTARGET; /* XXX does _anyone_ need this? --AD 2/20/1998 */ /* XXX netbsd still seemed to. XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style. @@ -3923,9 +3943,9 @@ PP(pp_telldir) long telldir (DIR *); # endif GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + 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))); @@ -3946,12 +3966,12 @@ nope: PP(pp_seekdir) { #if defined(HAS_SEEKDIR) || defined(seekdir) - dVAR; dSP; + dSP; const long along = POPl; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + 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))); @@ -3972,11 +3992,11 @@ nope: PP(pp_rewinddir) { #if defined(HAS_REWINDDIR) || defined(rewinddir) - dVAR; dSP; + dSP; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + 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))); @@ -3996,11 +4016,11 @@ nope: PP(pp_closedir) { #if defined(Direntry_t) && defined(HAS_READDIR) - dVAR; dSP; + dSP; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + 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))); @@ -4031,15 +4051,15 @@ nope: PP(pp_fork) { #ifdef HAS_FORK - dVAR; dSP; dTARGET; + 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 @@ -4051,7 +4071,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); @@ -4059,7 +4079,7 @@ PP(pp_fork) } #endif if (childpid < 0) - RETSETUNDEF; + RETPUSHUNDEF; if (!childpid) { #ifdef PERL_USES_PL_PIDSTATUS hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */ @@ -4076,7 +4096,7 @@ PP(pp_fork) PERL_FLUSHALL_FOR_CHILD; childpid = PerlProc_fork(); if (childpid == -1) - RETSETUNDEF; + RETPUSHUNDEF; PUSHi(childpid); RETURN; # else @@ -4088,7 +4108,7 @@ PP(pp_fork) PP(pp_wait) { #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__) - dVAR; dSP; dTARGET; + dSP; dTARGET; Pid_t childpid; int argflags; @@ -4116,7 +4136,7 @@ PP(pp_wait) PP(pp_waitpid) { #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__) - dVAR; dSP; dTARGET; + dSP; dTARGET; const int optype = POPi; const Pid_t pid = TOPi; Pid_t result; @@ -4145,7 +4165,7 @@ PP(pp_waitpid) PP(pp_system) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; #if defined(__LIBCATAMOUNT__) PL_statusvalue = -1; SP = ORIGMARK; @@ -4154,11 +4174,11 @@ PP(pp_system) I32 value; int result; - if (PL_tainting) { + if (TAINTING_get) { TAINT_ENV(); while (++MARK <= SP) { (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ - if (PL_tainted) + if (TAINT_get) break; } MARK = ORIGMARK; @@ -4170,13 +4190,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); @@ -4190,7 +4210,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; @@ -4244,13 +4264,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) { @@ -4298,14 +4319,14 @@ PP(pp_system) PP(pp_exec) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; I32 value; - if (PL_tainting) { + if (TAINTING_get) { TAINT_ENV(); while (++MARK <= SP) { (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ - if (PL_tainted) + if (TAINT_get) break; } MARK = ORIGMARK; @@ -4320,25 +4341,13 @@ PP(pp_exec) #ifdef VMS value = (I32)vms_do_aexec(NULL, MARK, SP); #else -# ifdef __OPEN_VM - { - (void ) do_aspawn(NULL, MARK, SP); - value = 0; - } -# else value = (I32)do_aexec(NULL, MARK, SP); -# endif #endif else { #ifdef VMS value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); #else -# ifdef __OPEN_VM - (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP))); - value = 0; -# else value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); -# endif #endif } @@ -4350,7 +4359,7 @@ PP(pp_exec) PP(pp_getppid) { #ifdef HAS_GETPPID - dVAR; dSP; dTARGET; + dSP; dTARGET; XPUSHi( getppid() ); RETURN; #else @@ -4361,7 +4370,7 @@ PP(pp_getppid) PP(pp_getpgrp) { #ifdef HAS_GETPGRP - dVAR; dSP; dTARGET; + dSP; dTARGET; Pid_t pgrp; const Pid_t pid = (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0); @@ -4376,14 +4385,14 @@ PP(pp_getpgrp) XPUSHi(pgrp); RETURN; #else - DIE(aTHX_ PL_no_func, "getpgrp()"); + DIE(aTHX_ PL_no_func, "getpgrp"); #endif } PP(pp_setpgrp) { #ifdef HAS_SETPGRP - dVAR; dSP; dTARGET; + dSP; dTARGET; Pid_t pgrp; Pid_t pid; pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0; @@ -4406,7 +4415,7 @@ PP(pp_setpgrp) #endif /* USE_BSDPGRP */ RETURN; #else - DIE(aTHX_ PL_no_func, "setpgrp()"); + DIE(aTHX_ PL_no_func, "setpgrp"); #endif } @@ -4419,20 +4428,20 @@ PP(pp_setpgrp) PP(pp_getpriority) { #ifdef HAS_GETPRIORITY - dVAR; dSP; dTARGET; + dSP; dTARGET; const int who = POPi; const int which = TOPi; SETi( getpriority(PRIORITY_WHICH_T(which), who) ); RETURN; #else - DIE(aTHX_ PL_no_func, "getpriority()"); + DIE(aTHX_ PL_no_func, "getpriority"); #endif } PP(pp_setpriority) { #ifdef HAS_SETPRIORITY - dVAR; dSP; dTARGET; + dSP; dTARGET; const int niceval = POPi; const int who = POPi; const int which = TOPi; @@ -4440,7 +4449,7 @@ PP(pp_setpriority) SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 ); RETURN; #else - DIE(aTHX_ PL_no_func, "setpriority()"); + DIE(aTHX_ PL_no_func, "setpriority"); #endif } @@ -4450,7 +4459,7 @@ PP(pp_setpriority) PP(pp_time) { - dVAR; dSP; dTARGET; + dSP; dTARGET; #ifdef BIG_TIME XPUSHn( time(NULL) ); #else @@ -4462,22 +4471,17 @@ PP(pp_time) 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 @@ -4508,7 +4512,6 @@ PP(pp_tms) PP(pp_gmtime) { - dVAR; dSP; Time64_T when; struct TM tmbuf; @@ -4555,30 +4558,27 @@ 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 %"IVdf, + dayname[tmbuf.tm_wday], + monname[tmbuf.tm_mon], + tmbuf.tm_mday, + tmbuf.tm_hour, + tmbuf.tm_min, + tmbuf.tm_sec, + (IV)tmbuf.tm_year + 1900)); + } } else { /* list context */ if ( err == NULL ) @@ -4602,7 +4602,7 @@ PP(pp_gmtime) PP(pp_alarm) { #ifdef HAS_ALARM - dVAR; dSP; dTARGET; + dSP; dTARGET; int anum; anum = POPi; anum = alarm((unsigned int)anum); @@ -4617,7 +4617,7 @@ PP(pp_alarm) PP(pp_sleep) { - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 duration; Time_t lasttime; Time_t when; @@ -4640,7 +4640,7 @@ PP(pp_sleep) PP(pp_shmwrite) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; const int op_type = PL_op->op_type; I32 value; @@ -4672,7 +4672,7 @@ PP(pp_shmwrite) PP(pp_semget) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; const int anum = do_ipcget(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) @@ -4687,7 +4687,7 @@ PP(pp_semget) PP(pp_semctl) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; const int anum = do_ipcctl(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) @@ -4732,10 +4732,10 @@ S_space_join_names_mortal(pTHX_ char *const *array) PP(pp_ghostent) { #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; - register char **elem; - register SV *sv; + char **elem; + SV *sv; #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */ struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int); struct hostent *gethostbyname(Netdb_name_t); @@ -4822,9 +4822,9 @@ PP(pp_ghostent) PP(pp_gnetent) { #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; - register SV *sv; + SV *sv; #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */ struct netent *getnetbyaddr(Netdb_net_t, int); struct netent *getnetbyname(Netdb_name_t); @@ -4895,9 +4895,9 @@ PP(pp_gnetent) PP(pp_gprotoent) { #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; - register SV *sv; + SV *sv; #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */ struct protoent *getprotobyname(Netdb_name_t); struct protoent *getprotobynumber(int); @@ -4955,9 +4955,9 @@ PP(pp_gprotoent) PP(pp_gservent) { #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; - register SV *sv; + SV *sv; #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */ struct servent *getservbyname(Netdb_name_t, Netdb_name_t); struct servent *getservbyport(int, Netdb_name_t); @@ -4978,9 +4978,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"); @@ -4998,11 +4996,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); @@ -5013,11 +5007,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)); } @@ -5029,7 +5019,7 @@ PP(pp_gservent) PP(pp_shostent) { - dVAR; dSP; + dSP; const int stayopen = TOPi; switch(PL_op->op_type) { case OP_SHOSTENT: @@ -5066,7 +5056,7 @@ PP(pp_shostent) PP(pp_ehostent) { - dVAR; dSP; + dSP; switch(PL_op->op_type) { case OP_EHOSTENT: #ifdef HAS_ENDHOSTENT @@ -5132,9 +5122,9 @@ PP(pp_ehostent) PP(pp_gpwent) { #ifdef HAS_PASSWD - dVAR; dSP; + dSP; I32 which = PL_op->op_type; - register SV *sv; + SV *sv; struct passwd *pwent = NULL; /* * We currently support only the SysV getsp* shadow password interface. @@ -5232,11 +5222,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); } @@ -5284,23 +5270,13 @@ 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 -# 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. @@ -5339,18 +5315,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); @@ -5365,7 +5337,7 @@ PP(pp_gpwent) PP(pp_ggrent) { #ifdef HAS_GROUP - dVAR; dSP; + dSP; const I32 which = PL_op->op_type; const struct group *grent; @@ -5391,11 +5363,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); } @@ -5411,11 +5379,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 @@ -5439,7 +5403,7 @@ PP(pp_ggrent) PP(pp_getlogin) { #ifdef HAS_GETLOGIN - dVAR; dSP; dTARGET; + dSP; dTARGET; char *tmps; EXTEND(SP, 1); if (!(tmps = PerlProc_getlogin())) @@ -5457,13 +5421,13 @@ PP(pp_getlogin) PP(pp_syscall) { #ifdef HAS_SYSCALL - dVAR; dSP; dMARK; dORIGMARK; dTARGET; - register I32 items = SP - MARK; + dSP; dMARK; dORIGMARK; dTARGET; + I32 items = SP - MARK; unsigned long a[20]; - register I32 i = 0; + I32 i = 0; IV retval = -1; - if (PL_tainting) { + if (TAINTING_get) { while (++MARK <= SP) { if (SvTAINTED(*MARK)) { TAINT; @@ -5517,30 +5481,6 @@ PP(pp_syscall) case 8: retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]); break; -#ifdef atarist - case 9: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]); - break; - case 10: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]); - break; - case 11: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], - a[10]); - break; - case 12: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], - a[10],a[11]); - break; - case 13: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], - a[10],a[11],a[12]); - break; - case 14: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], - a[10],a[11],a[12],a[13]); - break; -#endif /* atarist */ } SP = ORIGMARK; PUSHi(retval);