X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8eb023a9cc1ea46c4dc9b9bb6dd651817ac32889..ea317ccb31f6a2617f030e911668f46874f7dacb:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index c3d0505..d4f1b9f 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -49,10 +49,6 @@ # include #endif -#ifdef I_SYS_WAIT -# include -#endif - #ifdef I_SYS_RESOURCE # include #endif @@ -252,6 +248,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) if (setresuid(euid, ruid, (Uid_t)-1)) #endif #endif + /* diag_listed_as: entering effective %s failed */ Perl_croak(aTHX_ "entering effective uid failed"); #endif @@ -265,6 +262,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) if (setresgid(egid, rgid, (Gid_t)-1)) #endif #endif + /* diag_listed_as: entering effective %s failed */ Perl_croak(aTHX_ "entering effective gid failed"); #endif @@ -277,6 +275,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) if (setresuid(ruid, euid, (Uid_t)-1)) #endif #endif + /* diag_listed_as: leaving effective %s failed */ Perl_croak(aTHX_ "leaving effective uid failed"); #ifdef HAS_SETREGID @@ -286,6 +285,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) if (setresgid(rgid, egid, (Gid_t)-1)) #endif #endif + /* diag_listed_as: leaving effective %s failed */ Perl_croak(aTHX_ "leaving effective gid failed"); return res; @@ -358,7 +358,27 @@ PP(pp_glob) { dVAR; OP *result; - tryAMAGICunTARGET(iter, -1); + dSP; + /* make a copy of the pattern if it is gmagical, to ensure that magic + * is called once and only once */ + if (SvGMAGICAL(TOPm1s)) TOPm1s = sv_2mortal(newSVsv(TOPm1s)); + + tryAMAGICunTARGET(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL)); + + if (PL_op->op_flags & OPf_SPECIAL) { + /* call Perl-level glob function instead. Stack args are: + * MARK, wildcard, csh_glob context index + * 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; + } /* Note that we only ever get here if File::Glob fails to load * without at the same time croaking, for some reason, or if @@ -404,7 +424,6 @@ PP(pp_warn) { dVAR; dSP; dMARK; SV *exsv; - const char *pv; STRLEN len; if (SP - MARK > 1) { dTARGET; @@ -421,7 +440,7 @@ PP(pp_warn) exsv = TOPs; } - if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) { + if (SvROK(exsv) || (SvPV_const(exsv, len), len)) { /* well-formed exception supplied */ } else if (SvROK(ERRSV)) { @@ -434,7 +453,9 @@ PP(pp_warn) else { exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP); } - warn_sv(exsv); + if (SvROK(exsv) && !PL_warnhook) + Perl_warn(aTHX_ "%"SVf, SVfARG(exsv)); + else warn_sv(exsv); RETSETYES; } @@ -442,7 +463,6 @@ PP(pp_die) { dVAR; dSP; dMARK; SV *exsv; - const char *pv; STRLEN len; #ifdef VMS VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); @@ -457,7 +477,7 @@ PP(pp_die) exsv = TOPs; } - if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) { + if (SvROK(exsv) || (SvPV_const(exsv, len), len)) { /* well-formed exception supplied */ } else if (SvROK(ERRSV)) { @@ -492,6 +512,73 @@ PP(pp_die) /* I/O. */ +OP * +Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv, + const MAGIC *const mg, const U32 flags, U32 argc, ...) +{ + SV **orig_sp = sp; + I32 ret_args; + + PERL_ARGS_ASSERT_TIED_METHOD; + + /* Ensure that our flag bits do not overlap. */ + assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0); + assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0); + assert((TIED_METHOD_SAY & G_WANT) == 0); + + PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */ + PUSHSTACKi(PERLSI_MAGIC); + EXTEND(SP, argc+1); /* object + args */ + PUSHMARK(sp); + PUSHs(SvTIED_obj(sv, mg)); + if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) { + Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */ + sp += argc; + } + else if (argc) { + const U32 mortalize_not_needed + = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED; + va_list args; + va_start(args, argc); + do { + SV *const arg = va_arg(args, SV *); + if(mortalize_not_needed) + PUSHs(arg); + else + mPUSHs(arg); + } while (--argc); + va_end(args); + } + + PUTBACK; + ENTER_with_name("call_tied_method"); + if (flags & TIED_METHOD_SAY) { + /* local $\ = "\n" */ + SAVEGENERICSV(PL_ors_sv); + PL_ors_sv = newSVpvs("\n"); + } + ret_args = call_method(methname, flags & G_WANT); + SPAGAIN; + orig_sp = sp; + POPSTACK; + SPAGAIN; + if (ret_args) { /* copy results back to original stack */ + EXTEND(sp, ret_args); + Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*); + sp += ret_args; + PUTBACK; + } + LEAVE_with_name("call_tied_method"); + return NORMAL; +} + +#define tied_method0(a,b,c,d) \ + Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0) +#define tied_method1(a,b,c,d,e) \ + Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e) +#define tied_method2(a,b,c,d,e,f) \ + Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f) + PP(pp_open) { dVAR; dSP; @@ -509,26 +596,21 @@ PP(pp_open) DIE(aTHX_ PL_no_usym, "filehandle"); if ((io = GvIOp(gv))) { - MAGIC *mg; + const MAGIC *mg; IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; if (IoDIRP(io)) Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), - "Opening dirhandle %s also as a file", - GvENAME(gv)); + "Opening dirhandle %"HEKf" also as a file", + HEKfARG(GvENAME_HEK(gv))); mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { /* Method's args are same as ours ... */ /* ... except handle is replaced by the object */ - *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg); - PUSHMARK(MARK); - PUTBACK; - ENTER_with_name("call_OPEN"); - call_method("OPEN", G_SCALAR); - LEAVE_with_name("call_OPEN"); - SPAGAIN; - RETURN; + return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); } } @@ -551,58 +633,11 @@ PP(pp_open) RETURN; } -/* These are private to this function, which is private to this file. - Use 0x04 rather than the next available bit, to help the compiler if the - architecture can generate more efficient instructions. */ -#define MORTALIZE_NOT_NEEDED 0x04 -#define TIED_HANDLE_ARGC_SHIFT 3 - -static OP * -S_tied_handle_method(pTHX_ const char *const methname, SV **sp, - IO *const io, MAGIC *const mg, const U32 flags, ...) -{ - U32 argc = flags >> TIED_HANDLE_ARGC_SHIFT; - - PERL_ARGS_ASSERT_TIED_HANDLE_METHOD; - - /* Ensure that our flag bits do not overlap. */ - assert((MORTALIZE_NOT_NEEDED & G_WANT) == 0); - assert((G_WANT >> TIED_HANDLE_ARGC_SHIFT) == 0); - - PUSHMARK(sp); - PUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); - if (argc) { - const U32 mortalize_not_needed = flags & MORTALIZE_NOT_NEEDED; - va_list args; - va_start(args, flags); - do { - SV *const arg = va_arg(args, SV *); - if(mortalize_not_needed) - PUSHs(arg); - else - mPUSHs(arg); - } while (--argc); - va_end(args); - } - - PUTBACK; - ENTER_with_name("call_tied_handle_method"); - call_method(methname, flags & G_WANT); - LEAVE_with_name("call_tied_handle_method"); - return NORMAL; -} - -#define tied_handle_method(a,b,c,d) \ - S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR) -#define tied_handle_method1(a,b,c,d,e) \ - S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (1 << TIED_HANDLE_ARGC_SHIFT),e) -#define tied_handle_method2(a,b,c,d,e,f) \ - S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (2 << TIED_HANDLE_ARGC_SHIFT), e,f) - PP(pp_close) { dVAR; dSP; - GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs); + GV * const gv = + MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs); if (MAXARG == 0) EXTEND(SP, 1); @@ -610,9 +645,9 @@ PP(pp_close) if (gv) { IO * const io = GvIO(gv); if (io) { - MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - return tied_handle_method("CLOSE", SP, io, mg); + return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg); } } } @@ -685,23 +720,24 @@ PP(pp_fileno) GV *gv; IO *io; PerlIO *fp; - MAGIC *mg; + const MAGIC *mg; if (MAXARG < 1) RETPUSHUNDEF; gv = MUTABLE_GV(POPs); + io = GvIO(gv); - if (gv && (io = GvIO(gv)) + if (io && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { - return tied_handle_method("FILENO", SP, io, mg); + return tied_method0("FILENO", SP, MUTABLE_SV(io), mg); } - if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) { + if (!io || !(fp = IoIFP(io))) { /* Can't do this because people seem to do things like defined(fileno($foo)) to check whether $foo is a valid fh. - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + + report_evil_fh(gv); */ RETPUSHUNDEF; } @@ -718,7 +754,7 @@ PP(pp_umask) dTARGET; Mode_t anum; - if (MAXARG < 1) { + if (MAXARG < 1 || (!TOPs && !POPs)) { anum = PerlLIO_umask(022); /* setting it to 022 between the two calls to umask avoids * to have a window where the umask is set to 0 -- meaning @@ -734,7 +770,7 @@ PP(pp_umask) /* Only DIE if trying to restrict permissions on "user" (self). * Otherwise it's harmless and more useful to just return undef * since 'group' and 'other' concepts probably don't exist here. */ - if (MAXARG >= 1 && (POPi & 0700)) + if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700)) DIE(aTHX_ "umask not implemented"); XPUSHs(&PL_sv_undef); #endif @@ -756,25 +792,23 @@ PP(pp_binmode) } gv = MUTABLE_GV(POPs); + io = GvIO(gv); - if (gv && (io = GvIO(gv))) { - MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (io) { + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { /* This takes advantage of the implementation of the varargs 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 S_tied_handle_method(aTHX_ "BINMODE", SP, io, mg, - G_SCALAR|MORTALIZE_NOT_NEEDED - | (discp - ? (1 << TIED_HANDLE_ARGC_SHIFT) : 0), - discp); + return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg, + G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED, + discp ? 1 : 0, discp); } } - if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + if (!io || !(fp = IoIFP(io))) { + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } @@ -823,6 +857,13 @@ PP(pp_tie) break; case SVt_PVAV: methname = "TIEARRAY"; + if (!AvREAL(varsv)) { + if (!AvREIFY(varsv)) + Perl_croak(aTHX_ "Cannot tie unreifiable array"); + av_clear((AV *)varsv); + AvREIFY_off(varsv); + AvREAL_on(varsv); + } break; case SVt_PVGV: case SVt_PVLV: @@ -859,10 +900,8 @@ PP(pp_tie) * wrong error message, and worse case, supreme action at a distance. * (Sorry obfuscation writers. You're not going to be given this one.) */ - STRLEN len; - const char *name = SvPV_nomg_const(*MARK, len); - stash = gv_stashpvn(name, len, 0); - if (!stash || !(gv = gv_fetchmethod(stash, methname))) { + stash = gv_stashsv(*MARK, 0); + if (!stash || !(gv = gv_fetchmethod(stash, methname))) { DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"", methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no)); } @@ -945,10 +984,7 @@ PP(pp_tied) RETPUSHUNDEF; if ((mg = SvTIED_mg(sv, how))) { - SV *osv = SvTIED_obj(sv, mg); - if (osv == mg->mg_obj) - osv = sv_mortalcopy(osv); - PUSHs(osv); + PUSHs(SvTIED_obj(sv, mg)); RETURN; } RETPUSHUNDEF; @@ -981,7 +1017,10 @@ PP(pp_dbmopen) if (SvIV(right)) mPUSHu(O_RDWR|O_CREAT); else + { mPUSHu(O_RDWR); + if (!SvOK(right)) right = &PL_sv_no; + } PUSHs(right); PUTBACK; call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR); @@ -1038,6 +1077,7 @@ PP(pp_sselect) SP -= 4; for (i = 1; i <= 3; i++) { SV * const sv = SP[i]; + SvGETMAGIC(sv); if (!SvOK(sv)) continue; if (SvREADONLY(sv)) { @@ -1047,8 +1087,10 @@ PP(pp_sselect) Perl_croak_no_modify(aTHX); } if (!SvPOK(sv)) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask"); - SvPV_force_nolen(sv); /* force string conversion */ + if (!SvPOKp(sv)) + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Non-string passed as bitmask"); + SvPV_force_nomg_nolen(sv); /* force string conversion */ } j = SvCUR(sv); if (maxlen < j) @@ -1196,21 +1238,20 @@ PP(pp_select) HV *hv; GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL; GV * egv = GvEGVx(PL_defoutgv); + GV * const *gvp; if (!egv) egv = PL_defoutgv; hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL; - if (! hv) - XPUSHs(&PL_sv_undef); - else { - GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE); - if (gvp && *gvp == egv) { + gvp = hv && HvENAME(hv) + ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE) + : NULL; + if (gvp && *gvp == egv) { gv_efullname4(TARG, PL_defoutgv, NULL, TRUE); XPUSHTARG; - } - else { + } + else { mXPUSHs(newRV(MUTABLE_SV(egv))); - } } if (newdefout) { @@ -1225,17 +1266,18 @@ PP(pp_select) PP(pp_getc) { dVAR; dSP; dTARGET; - IO *io = NULL; - GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs); + GV * const gv = + MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs); + IO *const io = GvIO(gv); if (MAXARG == 0) EXTEND(SP, 1); - if (gv && (io = GvIO(gv))) { - MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (io) { + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { const U32 gimme = GIMME_V; - S_tied_handle_method(aTHX_ "GETC", SP, io, mg, gimme); + Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0); if (gimme == G_SCALAR) { SPAGAIN; SvSetMagicSV_nosteal(TARG, TOPs); @@ -1244,9 +1286,8 @@ PP(pp_getc) } } if (!gv || do_eof(gv)) { /* make sure we have fp with something */ - if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)) - && ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)) + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } @@ -1324,12 +1365,10 @@ PP(pp_enterwrite) cv = GvFORM(fgv); if (!cv) { - const char *name; tmpsv = sv_newmortal(); gv_efullname4(tmpsv, fgv, NULL, FALSE); - name = SvPV_nolen_const(tmpsv); - if (name && *name) - DIE(aTHX_ "Undefined format \"%s\" called", name); + if (SvPOK(tmpsv) && *SvPV_nolen_const(tmpsv)) + DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv)); not_a_format_reference: DIE(aTHX_ "Not a format reference"); @@ -1368,7 +1407,8 @@ PP(pp_leavewrite) SV *topname; if (!IoFMT_NAME(io)) IoFMT_NAME(io) = savepv(GvNAME(gv)); - topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv))); + topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP", + HEKfARG(GvNAME_HEK(gv)))); topgv = gv_fetchsv(topname, 0, SVt_PVFM); if ((topgv && GvFORM(topgv)) || !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM)) @@ -1415,11 +1455,9 @@ PP(pp_leavewrite) cv = GvFORM(fgv); if (!cv) { SV * const sv = sv_newmortal(); - const char *name; gv_efullname4(sv, fgv, NULL, FALSE); - name = SvPV_nolen_const(sv); - if (name && *name) - DIE(aTHX_ "Undefined top format \"%s\" called", name); + if (SvPOK(sv) && *SvPV_nolen_const(sv)) + DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv)); else DIE(aTHX_ "Undefined top format called"); } @@ -1434,12 +1472,10 @@ PP(pp_leavewrite) fp = IoOFP(io); if (!fp) { - if (ckWARN2(WARN_CLOSED,WARN_IO)) { - if (IoIFP(io)) - report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); - else if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); - } + if (IoIFP(io)) + report_wrongway_fh(gv, '<'); + else + report_evil_fh(gv); PUSHs(&PL_sv_no); } else { @@ -1468,15 +1504,15 @@ PP(pp_leavewrite) PP(pp_prtf) { dVAR; dSP; dMARK; dORIGMARK; - IO *io; PerlIO *fp; SV *sv; GV * const gv = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv; + IO *const io = GvIO(gv); - if (gv && (io = GvIO(gv))) { - MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (io) { + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { if (MARK == ORIGMARK) { MEXTEND(SP, 1); @@ -1484,40 +1520,28 @@ PP(pp_prtf) Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); ++SP; } - PUSHMARK(MARK - 1); - *MARK = SvTIED_obj(MUTABLE_SV(io), mg); - PUTBACK; - ENTER; - call_method("PRINTF", G_SCALAR); - LEAVE; - SPAGAIN; - MARK = ORIGMARK + 1; - *MARK = *SP; - SP = MARK; - RETURN; + return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io), + mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); } } sv = newSV(0); - if (!(io = GvIO(gv))) { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + if (!io) { + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { - if (ckWARN2(WARN_CLOSED,WARN_IO)) { - if (IoIFP(io)) - report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); - else if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); - } + if (IoIFP(io)) + report_wrongway_fh(gv, '<'); + else if (ckWARN(WARN_CLOSED)) + report_evil_fh(gv); SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); goto just_say_no; } else { - if (SvTAINTED(MARK[1])) - TAINT_PROPER("printf"); do_sprintf(sv, SP - MARK, MARK + 1); if (!do_print(sv, fp)) goto just_say_no; @@ -1542,7 +1566,7 @@ PP(pp_sysopen) { dVAR; dSP; - const int perm = (MAXARG > 3) ? POPi : 0666; + const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666; const int mode = POPi; SV * const sv = POPs; GV * const gv = MUTABLE_GV(POPs); @@ -1564,12 +1588,12 @@ PP(pp_sysopen) PP(pp_sysread) { dVAR; dSP; dMARK; dORIGMARK; dTARGET; - int offset; + SSize_t offset; IO *io; char *buffer; + STRLEN orig_size; SSize_t length; SSize_t count; - Sock_size_t bufsize; SV *bufsv; STRLEN blen; int fp_utf8; @@ -1585,19 +1609,11 @@ PP(pp_sysread) if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) && gv && (io = GvIO(gv)) ) { - const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - SV *sv; - PUSHMARK(MARK-1); - *MARK = SvTIED_obj(MUTABLE_SV(io), mg); - ENTER; - call_method("READ", G_SCALAR); - LEAVE; - SPAGAIN; - sv = POPs; - SP = ORIGMARK; - PUSHs(sv); - RETURN; + return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); } } @@ -1614,8 +1630,7 @@ PP(pp_sysread) offset = 0; io = GvIO(gv); if (!io || !IoIFP(io)) { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); goto say_undef; } @@ -1639,6 +1654,7 @@ PP(pp_sysread) #ifdef HAS_SOCKET 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__) bufsize = sizeof (struct sockaddr_in); @@ -1676,16 +1692,13 @@ PP(pp_sysread) PUSHs(TARG); RETURN; } -#else - if (PL_op->op_type == OP_RECV) - DIE(aTHX_ PL_no_sock_func, "recv"); #endif if (DO_UTF8(bufsv)) { /* offset adjust in characters not bytes */ blen = sv_len_utf8(bufsv); } if (offset < 0) { - if (-offset > (int)blen) + if (-offset > (SSize_t)blen) DIE(aTHX_ "Offset outside string"); offset += blen; } @@ -1697,15 +1710,15 @@ PP(pp_sysread) offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; } more_bytes: - bufsize = SvCUR(bufsv); + 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 unduly. (should be 2 * length + offset + 1, or possibly something longer if PL_encoding is true) */ buffer = SvGROW(bufsv, (STRLEN)(length+offset+1)); - if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */ - Zero(buffer+bufsize, offset-bufsize, char); + if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */ + Zero(buffer+orig_size, offset-orig_size, char); } buffer = buffer + offset; if (!buffer_utf8) { @@ -1739,6 +1752,7 @@ PP(pp_sysread) else #ifdef HAS_SOCKET__bad_code_maybe if (IoTYPE(io) == IoTYPE_SOCKET) { + Sock_size_t bufsize; char namebuf[MAXPATHLEN]; #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS) bufsize = sizeof (struct sockaddr_in); @@ -1757,8 +1771,8 @@ PP(pp_sysread) count = -1; } if (count < 0) { - if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO)) - report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY); + if (IoTYPE(io) == IoTYPE_WRONLY) + report_wrongway_fh(gv, '>'); goto say_undef; } SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target))); @@ -1817,10 +1831,9 @@ PP(pp_sysread) RETPUSHUNDEF; } -PP(pp_send) +PP(pp_syswrite) { dVAR; dSP; dMARK; dORIGMARK; dTARGET; - IO *io; SV *bufsv; const char *buffer; SSize_t retval; @@ -1829,30 +1842,21 @@ PP(pp_send) const int op_type = PL_op->op_type; bool doing_utf8; U8 *tmpbuf = NULL; - GV *const gv = MUTABLE_GV(*++MARK); - if (PL_op->op_type == OP_SYSWRITE - && gv && (io = GvIO(gv))) { - MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); - if (mg) { - SV *sv; + IO *const io = GvIO(gv); + if (op_type == OP_SYSWRITE && io) { + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (mg) { if (MARK == SP - 1) { - sv = *SP; + SV *sv = *SP; mXPUSHi(sv_len(sv)); PUTBACK; } - PUSHMARK(ORIGMARK); - *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg); - ENTER; - call_method("WRITE", G_SCALAR); - LEAVE; - SPAGAIN; - sv = POPs; - SP = ORIGMARK; - PUSHs(sv); - RETURN; + return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); } } if (!gv) @@ -1861,15 +1865,12 @@ PP(pp_send) bufsv = *++MARK; SETERRNO(0,0); - io = GvIO(gv); if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) { retval = -1; - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) { - if (io && IoIFP(io)) - report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); - else - report_evil_fh(gv, io, PL_op->op_type); - } + if (io && IoIFP(io)) + report_wrongway_fh(gv, '<'); + else + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); goto say_undef; } @@ -1901,7 +1902,23 @@ PP(pp_send) } } - if (op_type == OP_SYSWRITE) { +#ifdef HAS_SOCKET + if (op_type == OP_SEND) { + const int flags = SvIVx(*++MARK); + if (SP > MARK) { + STRLEN mlen; + char * const sockbuf = SvPVx(*++MARK, mlen); + retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, + flags, (struct sockaddr *)sockbuf, mlen); + } + else { + retval + = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags); + } + } + else +#endif + { Size_t length = 0; /* This length is in characters. */ STRLEN blen_chars; IV offset; @@ -1996,24 +2013,6 @@ PP(pp_send) buffer, length); } } -#ifdef HAS_SOCKET - else { - const int flags = SvIVx(*++MARK); - if (SP > MARK) { - STRLEN mlen; - char * const sockbuf = SvPVx(*++MARK, mlen); - retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, - flags, (struct sockaddr *)sockbuf, mlen); - } - else { - retval - = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags); - } - } -#else - else - DIE(aTHX_ PL_no_sock_func, "send"); -#endif if (retval < 0) goto say_undef; @@ -2040,7 +2039,7 @@ PP(pp_eof) dVAR; dSP; GV *gv; IO *io; - MAGIC *mg; + const MAGIC *mg; /* * in Perl 5.12 and later, the additional parameter is a bitmask: * 0 = eof @@ -2074,7 +2073,7 @@ PP(pp_eof) RETPUSHNO; if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { - return tied_handle_method1("EOF", SP, io, mg, newSVuv(which)); + return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which)); } if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */ @@ -2104,16 +2103,17 @@ PP(pp_tell) GV *gv; IO *io; - if (MAXARG != 0) + if (MAXARG != 0 && (TOPs || POPs)) PL_last_in_gv = MUTABLE_GV(POPs); else EXTEND(SP, 1); gv = PL_last_in_gv; - if (gv && (io = GvIO(gv))) { - MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + io = GvIO(gv); + if (io) { + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - return tied_handle_method("TELL", SP, io, mg); + return tied_method0("TELL", SP, MUTABLE_SV(io), mg); } } else if (!gv) { @@ -2142,10 +2142,10 @@ PP(pp_sysseek) #endif GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs); - IO *io; + IO *const io = GvIO(gv); - if (gv && (io = GvIO(gv))) { - MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (io) { + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { #if LSEEKSIZE > IVSIZE SV *const offset_sv = newSVnv((NV) offset); @@ -2153,8 +2153,8 @@ PP(pp_sysseek) SV *const offset_sv = newSViv(offset); #endif - return tied_handle_method2("SEEK", SP, io, mg, offset_sv, - newSViv(whence)); + return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv, + newSViv(whence)); } } @@ -2199,19 +2199,19 @@ PP(pp_truncate) /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */ SETERRNO(0,0); { + SV * const sv = POPs; int result = 1; GV *tmpgv; IO *io; - if (PL_op->op_flags & OPf_SPECIAL) { - tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO); - - do_ftruncate_gv: - if (!GvIO(tmpgv)) + if ((tmpgv = PL_op->op_flags & OPf_SPECIAL + ? gv_fetchsv(sv, 0, SVt_PVIO) + : MAYBE_DEREF_GV(sv) )) { + io = GvIO(tmpgv); + if (!io) result = 0; else { PerlIO *fp; - io = GvIOp(tmpgv); do_ftruncate_io: TAINT_PROPER("truncate"); if (!(fp = IoIFP(io))) { @@ -2228,24 +2228,12 @@ PP(pp_truncate) } } } - else { - SV * const sv = POPs; - const char *name; - - if (isGV_with_GP(sv)) { - tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */ - goto do_ftruncate_gv; - } - else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) { - tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */ - goto do_ftruncate_gv; - } - else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { + else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */ goto do_ftruncate_io; - } - - name = SvPV_nolen_const(sv); + } + else { + const char * const name = SvPV_nomg_const_nolen(sv); TAINT_PROPER("truncate"); #ifdef HAS_TRUNCATE if (truncate(name, len) < 0) @@ -2285,8 +2273,7 @@ PP(pp_ioctl) IV retval; if (!io || !argsv || !IoIFP(io)) { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); /* well, sort of... */ RETPUSHUNDEF; } @@ -2353,25 +2340,18 @@ PP(pp_flock) #ifdef FLOCK dVAR; dSP; dTARGET; I32 value; - IO *io = NULL; - PerlIO *fp; const int argtype = POPi; GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs); + IO *const io = GvIO(gv); + PerlIO *const fp = io ? IoIFP(io) : NULL; - if (gv && (io = GvIO(gv))) - fp = IoIFP(io); - else { - fp = NULL; - io = NULL; - } /* XXX Looks to me like io is always NULL at this point */ if (fp) { (void)PerlIO_flush(fp); value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0); } else { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); value = 0; SETERRNO(EBADF,RMS_IFI); } @@ -2384,9 +2364,10 @@ PP(pp_flock) /* Sockets. */ +#ifdef HAS_SOCKET + PP(pp_socket) { -#ifdef HAS_SOCKET dVAR; dSP; const int protocol = POPi; const int type = POPi; @@ -2395,9 +2376,8 @@ PP(pp_socket) register IO * const io = gv ? GvIOn(gv) : NULL; int fd; - if (!gv || !io) { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + if (!io) { + report_evil_fh(gv); if (io && IoIFP(io)) do_close(gv, FALSE); SETERRNO(EBADF,LIB_INVARG); @@ -2429,10 +2409,8 @@ PP(pp_socket) #endif RETPUSHYES; -#else - DIE(aTHX_ PL_no_sock_func, "socket"); -#endif } +#endif PP(pp_sockpair) { @@ -2447,25 +2425,19 @@ PP(pp_sockpair) register IO * const io2 = gv2 ? GvIOn(gv2) : NULL; int fd[2]; - if (!gv1 || !gv2 || !io1 || !io2) { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) { - if (!gv1 || !io1) - report_evil_fh(gv1, io1, PL_op->op_type); - if (!gv2 || !io2) - report_evil_fh(gv1, io2, PL_op->op_type); - } - if (io1 && IoIFP(io1)) - do_close(gv1, FALSE); - if (io2 && IoIFP(io2)) - do_close(gv2, FALSE); - RETPUSHUNDEF; - } + if (!io1) + report_evil_fh(gv1); + if (!io2) + report_evil_fh(gv2); - if (IoIFP(io1)) + if (io1 && IoIFP(io1)) do_close(gv1, FALSE); - if (IoIFP(io2)) + if (io2 && IoIFP(io2)) do_close(gv2, FALSE); + if (!io1 || !io2) + RETPUSHUNDEF; + TAINT_PROPER("socketpair"); if (PerlSock_socketpair(domain, type, protocol, fd) < 0) RETPUSHUNDEF; @@ -2495,9 +2467,10 @@ PP(pp_sockpair) #endif } +#ifdef HAS_SOCKET + PP(pp_bind) { -#ifdef HAS_SOCKET dVAR; dSP; SV * const addrsv = POPs; /* OK, so on what platform does bind modify addr? */ @@ -2505,66 +2478,35 @@ PP(pp_bind) GV * const gv = MUTABLE_GV(POPs); register IO * const io = GvIOn(gv); STRLEN len; + const int op_type = PL_op->op_type; if (!io || !IoIFP(io)) goto nuts; addr = SvPV_const(addrsv, len); - TAINT_PROPER("bind"); - if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) - RETPUSHYES; - else - RETPUSHUNDEF; - -nuts: - if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,SS_IVCHAN); - RETPUSHUNDEF; -#else - DIE(aTHX_ PL_no_sock_func, "bind"); -#endif -} - -PP(pp_connect) -{ -#ifdef HAS_SOCKET - dVAR; dSP; - SV * const addrsv = POPs; - GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); - const char *addr; - STRLEN len; - - if (!io || !IoIFP(io)) - goto nuts; - - addr = SvPV_const(addrsv, len); - TAINT_PROPER("connect"); - if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) + 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)) + >= 0) RETPUSHYES; else RETPUSHUNDEF; nuts: - if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; -#else - DIE(aTHX_ PL_no_sock_func, "connect"); -#endif } PP(pp_listen) { -#ifdef HAS_SOCKET dVAR; dSP; const int backlog = POPi; GV * const gv = MUTABLE_GV(POPs); register IO * const io = gv ? GvIOn(gv) : NULL; - if (!gv || !io || !IoIFP(io)) + if (!io || !IoIFP(io)) goto nuts; if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0) @@ -2573,18 +2515,13 @@ PP(pp_listen) RETPUSHUNDEF; nuts: - if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; -#else - DIE(aTHX_ PL_no_sock_func, "listen"); -#endif } PP(pp_accept) { -#ifdef HAS_SOCKET dVAR; dSP; dTARGET; register IO *nstio; register IO *gstio; @@ -2649,21 +2586,16 @@ PP(pp_accept) RETURN; nuts: - if (ckWARN(WARN_CLOSED)) - report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type); + report_evil_fh(ggv); SETERRNO(EBADF,SS_IVCHAN); badexit: RETPUSHUNDEF; -#else - DIE(aTHX_ PL_no_sock_func, "accept"); -#endif } PP(pp_shutdown) { -#ifdef HAS_SOCKET dVAR; dSP; dTARGET; const int how = POPi; GV * const gv = MUTABLE_GV(POPs); @@ -2676,18 +2608,13 @@ PP(pp_shutdown) RETURN; nuts: - if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; -#else - DIE(aTHX_ PL_no_sock_func, "shutdown"); -#endif } PP(pp_ssockopt) { -#ifdef HAS_SOCKET dVAR; dSP; const int optype = PL_op->op_type; SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs; @@ -2751,20 +2678,15 @@ PP(pp_ssockopt) RETURN; nuts: - if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, optype); + report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); nuts2: RETPUSHUNDEF; -#else - DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); -#endif } PP(pp_getpeername) { -#ifdef HAS_SOCKET dVAR; dSP; const int optype = PL_op->op_type; GV * const gv = MUTABLE_GV(POPs); @@ -2815,16 +2737,13 @@ PP(pp_getpeername) RETURN; nuts: - if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, optype); + report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); nuts2: RETPUSHUNDEF; +} -#else - DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif -} /* Stat calls. */ @@ -2833,67 +2752,67 @@ PP(pp_stat) dVAR; dSP; GV *gv = NULL; - IO *io; + IO *io = NULL; I32 gimme; I32 max = 13; + SV* sv; - if (PL_op->op_flags & OPf_REF) { - gv = cGVOP_gv; + if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1) + : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) { if (PL_op->op_type == OP_LSTAT) { if (gv != PL_defgv) { do_fstat_warning_check: Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "lstat() on filehandle %s", gv ? GvENAME(gv) : ""); + "lstat() on filehandle%s%"SVf, + gv ? " " : "", + SVfARG(gv + ? sv_2mortal(newSVhek(GvENAME_HEK(gv))) + : &PL_sv_no)); } else if (PL_laststype != OP_LSTAT) + /* diag_listed_as: The stat preceding %s wasn't an lstat */ Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); } - do_fstat: if (gv != PL_defgv) { + bool havefp; + do_fstat_have_io: + havefp = FALSE; PL_laststype = OP_STAT; - PL_statgv = gv; + PL_statgv = gv ? gv : (GV *)io; sv_setpvs(PL_statname, ""); if(gv) { io = GvIO(gv); - do_fstat_have_io: - if (io) { + } + if (io) { if (IoIFP(io)) { PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache); + havefp = TRUE; } else if (IoDIRP(io)) { PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache); + havefp = TRUE; } else { PL_laststatval = -1; } - } } + else PL_laststatval = -1; + if (PL_laststatval < 0 && !havefp) report_evil_fh(gv); } if (PL_laststatval < 0) { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, GvIO(gv), PL_op->op_type); max = 0; } } else { - SV* const sv = POPs; - if (isGV_with_GP(sv)) { - gv = MUTABLE_GV(sv); - goto do_fstat; - } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) { - gv = MUTABLE_GV(SvRV(sv)); - if (PL_op->op_type == OP_LSTAT) - goto do_fstat_warning_check; - goto do_fstat; - } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { + if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { io = MUTABLE_IO(SvRV(sv)); if (PL_op->op_type == OP_LSTAT) goto do_fstat_warning_check; goto do_fstat_have_io; } - sv_setpv(PL_statname, SvPV_nolen_const(sv)); + sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv)); PL_statgv = NULL; PL_laststype = PL_op->op_type; if (PL_op->op_type == OP_LSTAT) @@ -2917,7 +2836,15 @@ PP(pp_stat) EXTEND(SP, max); EXTEND_MORTAL(max); mPUSHi(PL_statcache.st_dev); +#if ST_INO_SIZE > IVSIZE + mPUSHn(PL_statcache.st_ino); +#else +# if ST_INO_SIGN <= 0 mPUSHi(PL_statcache.st_ino); +# else + mPUSHu(PL_statcache.st_ino); +# endif +#endif mPUSHu(PL_statcache.st_mode); mPUSHu(PL_statcache.st_nlink); #if Uid_t_size > IVSIZE @@ -2968,62 +2895,81 @@ PP(pp_stat) RETURN; } +/* 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, + and skip the stacked operators on failure. + The next few macros/functions take care of this. +*/ + +static OP * +S_ft_stacking_return_false(pTHX_ SV *ret) { + dSP; + OP *next = NORMAL; + while (OP_IS_FILETEST(next->op_type) + && next->op_private & OPpFT_STACKED) + next = next->op_next; + if (PL_op->op_flags & OPf_REF) PUSHs(ret); + else SETs(ret); + PUTBACK; + 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(PUSHs(X)); \ + } STMT_END +#define FT_RETURN_TRUE(X) \ + RETURNX((void)( \ + PL_op->op_private & OPpFT_STACKING \ + ? PL_op->op_flags & OPf_REF \ + ? PUSHs((SV *)cGVOP_gv) \ + : 0 \ + : PUSHs(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) + #define tryAMAGICftest_MG(chr) STMT_START { \ if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \ - && S_try_amagic_ftest(aTHX_ chr)) \ - return NORMAL; \ + && PL_op->op_flags & OPf_KIDS) { \ + OP *next = S_try_amagic_ftest(aTHX_ chr); \ + if (next) return next; \ + } \ } STMT_END -STATIC bool +STATIC OP * S_try_amagic_ftest(pTHX_ char chr) { dVAR; dSP; SV* const arg = TOPs; assert(chr != '?'); - SvGETMAGIC(arg); + if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg); - if ((PL_op->op_flags & OPf_KIDS) - && SvAMAGIC(TOPs)) + if (SvAMAGIC(TOPs)) { const char tmpchr = chr; - const OP *next; SV * const tmpsv = amagic_call(arg, newSVpvn_flags(&tmpchr, 1, SVs_TEMP), ftest_amg, AMGf_unary); if (!tmpsv) - return FALSE; + return NULL; SPAGAIN; - next = PL_op->op_next; - if (next->op_type >= OP_FTRREAD && - next->op_type <= OP_FTBINARY && - next->op_private & OPpFT_STACKED - ) { - if (SvTRUE(tmpsv)) - /* leave the object alone */ - return TRUE; - } - - SETs(tmpsv); - PUTBACK; - return TRUE; + if (SvTRUE(tmpsv)) FT_RETURN_TRUE(tmpsv); + FT_RETURN_FALSE(tmpsv); } - return FALSE; + return NULL; } -/* This macro is used by the stacked filetest operators : - * if the previous filetest failed, short-circuit and pass its value. - * Else, discard it from the stack and continue. --rgs - */ -#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \ - if (!SvTRUE(TOPs)) { RETURN; } \ - else { (void)POPs; PUTBACK; } \ - } - PP(pp_ftrread) { dVAR; @@ -3043,7 +2989,7 @@ PP(pp_ftrread) conditional compiling below much clearer. */ I32 use_access = 0; #endif - int stat_mode = S_IRUSR; + Mode_t stat_mode = S_IRUSR; bool effective = FALSE; char opchar = '?'; @@ -3059,8 +3005,6 @@ PP(pp_ftrread) } tryAMAGICftest_MG(opchar); - STACKED_FTEST_CHECK; - switch (PL_op->op_type) { case OP_FTRREAD: #if !(defined(HAS_ACCESS) && defined(R_OK)) @@ -3140,10 +3084,10 @@ PP(pp_ftrread) result = my_stat_flags(0); SPAGAIN; if (result < 0) - RETPUSHUNDEF; + FT_RETURNUNDEF; if (cando(stat_mode, effective, &PL_statcache)) - RETPUSHYES; - RETPUSHNO; + FT_RETURNYES; + FT_RETURNNO; } PP(pp_ftis) @@ -3163,14 +3107,12 @@ PP(pp_ftis) } tryAMAGICftest_MG(opchar); - STACKED_FTEST_CHECK; - result = my_stat_flags(0); SPAGAIN; if (result < 0) - RETPUSHUNDEF; + FT_RETURNUNDEF; if (op_type == OP_FTIS) - RETPUSHYES; + FT_RETURNYES; { /* You can't dTARGET inside OP_FTIS, because you'll get "panic: pad_sv po" - the op is not flagged to have a target. */ @@ -3178,23 +3120,28 @@ PP(pp_ftis) switch (op_type) { case OP_FTSIZE: #if Off_t_size > IVSIZE - PUSHn(PL_statcache.st_size); + sv_setnv(TARG, (NV)PL_statcache.st_size); #else - PUSHi(PL_statcache.st_size); + sv_setiv(TARG, (IV)PL_statcache.st_size); #endif break; case OP_FTMTIME: - PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 ); + sv_setnv(TARG, + ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 ); break; case OP_FTATIME: - PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 ); + sv_setnv(TARG, + ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 ); break; case OP_FTCTIME: - PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 ); + sv_setnv(TARG, + ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 ); break; } + SvSETMAGIC(TARG); + if (SvTRUE_nomg(TARG)) FT_RETURN_TRUE(TARG); + else FT_RETURN_FALSE(TARG); } - RETURN; } PP(pp_ftrowned) @@ -3220,93 +3167,91 @@ PP(pp_ftrowned) } tryAMAGICftest_MG(opchar); - STACKED_FTEST_CHECK; - /* I believe that all these three are likely to be defined on most every system these days. */ #ifndef S_ISUID if(PL_op->op_type == OP_FTSUID) { - if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0) + if ((PL_op->op_flags & OPf_REF) == 0 && !(PL_op->op_private & OPpFT_STACKING)) (void) POPs; - RETPUSHNO; + FT_RETURNNO; } #endif #ifndef S_ISGID if(PL_op->op_type == OP_FTSGID) { - if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0) + if ((PL_op->op_flags & OPf_REF) == 0 && !(PL_op->op_private & OPpFT_STACKING)) (void) POPs; - RETPUSHNO; + FT_RETURNNO; } #endif #ifndef S_ISVTX if(PL_op->op_type == OP_FTSVTX) { - if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0) + if ((PL_op->op_flags & OPf_REF) == 0 && !(PL_op->op_private & OPpFT_STACKING)) (void) POPs; - RETPUSHNO; + FT_RETURNNO; } #endif result = my_stat_flags(0); SPAGAIN; if (result < 0) - RETPUSHUNDEF; + FT_RETURNUNDEF; switch (PL_op->op_type) { case OP_FTROWNED: if (PL_statcache.st_uid == PL_uid) - RETPUSHYES; + FT_RETURNYES; break; case OP_FTEOWNED: if (PL_statcache.st_uid == PL_euid) - RETPUSHYES; + FT_RETURNYES; break; case OP_FTZERO: if (PL_statcache.st_size == 0) - RETPUSHYES; + FT_RETURNYES; break; case OP_FTSOCK: if (S_ISSOCK(PL_statcache.st_mode)) - RETPUSHYES; + FT_RETURNYES; break; case OP_FTCHR: if (S_ISCHR(PL_statcache.st_mode)) - RETPUSHYES; + FT_RETURNYES; break; case OP_FTBLK: if (S_ISBLK(PL_statcache.st_mode)) - RETPUSHYES; + FT_RETURNYES; break; case OP_FTFILE: if (S_ISREG(PL_statcache.st_mode)) - RETPUSHYES; + FT_RETURNYES; break; case OP_FTDIR: if (S_ISDIR(PL_statcache.st_mode)) - RETPUSHYES; + FT_RETURNYES; break; case OP_FTPIPE: if (S_ISFIFO(PL_statcache.st_mode)) - RETPUSHYES; + FT_RETURNYES; break; #ifdef S_ISUID case OP_FTSUID: if (PL_statcache.st_mode & S_ISUID) - RETPUSHYES; + FT_RETURNYES; break; #endif #ifdef S_ISGID case OP_FTSGID: if (PL_statcache.st_mode & S_ISGID) - RETPUSHYES; + FT_RETURNYES; break; #endif #ifdef S_ISVTX case OP_FTSVTX: if (PL_statcache.st_mode & S_ISVTX) - RETPUSHYES; + FT_RETURNYES; break; #endif } - RETPUSHNO; + FT_RETURNNO; } PP(pp_ftlink) @@ -3320,10 +3265,10 @@ PP(pp_ftlink) SPAGAIN; if (result < 0) - RETPUSHUNDEF; + FT_RETURNUNDEF; if (S_ISLNK(PL_statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; + FT_RETURNYES; + FT_RETURNNO; } PP(pp_fttty) @@ -3332,39 +3277,30 @@ PP(pp_fttty) dSP; int fd; GV *gv; - SV *tmpsv = NULL; char *name = NULL; STRLEN namelen; tryAMAGICftest_MG('t'); - STACKED_FTEST_CHECK; - if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; - else if (isGV_with_GP(TOPs)) - gv = MUTABLE_GV(POPs); - else if (SvROK(TOPs) && isGV(SvRV(TOPs))) - gv = MUTABLE_GV(SvRV(POPs)); else { - tmpsv = POPs; + SV *tmpsv = PL_op->op_private & OPpFT_STACKING ? TOPs : POPs; + if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) { name = SvPV_nomg(tmpsv, namelen); gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO); + } } if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); - else if (tmpsv && SvOK(tmpsv)) { - if (isDIGIT(*name)) + else if (name && isDIGIT(*name)) fd = atoi(name); - else - RETPUSHUNDEF; - } else - RETPUSHUNDEF; + FT_RETURNUNDEF; if (PerlLIO_isatty(fd)) - RETPUSHYES; - RETPUSHNO; + FT_RETURNYES; + FT_RETURNNO; } #if defined(atarist) /* this will work with atariST. Configure will @@ -3385,50 +3321,53 @@ PP(pp_fttext) STDCHAR tbuf[512]; register STDCHAR *s; register IO *io; - register SV *sv; + register SV *sv = NULL; GV *gv; PerlIO *fp; tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B'); - STACKED_FTEST_CHECK; - if (PL_op->op_flags & OPf_REF) + { gv = cGVOP_gv; - else if (isGV_with_GP(TOPs)) - gv = MUTABLE_GV(POPs); - else if (SvROK(TOPs) && isGV(SvRV(TOPs))) - gv = MUTABLE_GV(SvRV(POPs)); - else - gv = NULL; + EXTEND(SP, 1); + } + else { + sv = PL_op->op_private & OPpFT_STACKING ? TOPs : POPs; + if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) + == OPpFT_STACKED) + gv = PL_defgv; + else gv = MAYBE_DEREF_GV_nomg(sv); + } if (gv) { - EXTEND(SP, 1); if (gv == PL_defgv) { if (PL_statgv) - io = GvIO(PL_statgv); + io = SvTYPE(PL_statgv) == SVt_PVIO + ? (IO *)PL_statgv + : GvIO(PL_statgv); else { - sv = PL_statname; goto really_filename; } } else { PL_statgv = gv; - PL_laststatval = -1; sv_setpvs(PL_statname, ""); io = GvIO(PL_statgv); } + PL_laststatval = -1; + PL_laststype = OP_STAT; if (io && IoIFP(io)) { 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); if (PL_laststatval < 0) - RETPUSHUNDEF; + FT_RETURNUNDEF; if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */ if (PL_op->op_type == OP_FTTEXT) - RETPUSHNO; + FT_RETURNNO; else - RETPUSHYES; + FT_RETURNYES; } if (PerlIO_get_cnt(IoIFP(io)) <= 0) { i = PerlIO_getc(IoIFP(io)); @@ -3436,7 +3375,7 @@ PP(pp_fttext) (void)PerlIO_ungetc(IoIFP(io),i); } if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */ - RETPUSHYES; + FT_RETURNYES; len = PerlIO_get_bufsiz(IoIFP(io)); s = (STDCHAR *) PerlIO_get_base(IoIFP(io)); /* sfio can have large buffers - limit to 512 */ @@ -3444,38 +3383,39 @@ PP(pp_fttext) len = 512; } else { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) { - gv = cGVOP_gv; - report_evil_fh(gv, GvIO(gv), PL_op->op_type); - } SETERRNO(EBADF,RMS_IFI); - RETPUSHUNDEF; + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); + FT_RETURNUNDEF; } } else { - sv = POPs; + sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv)); really_filename: PL_statgv = NULL; - PL_laststype = OP_STAT; - sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv)); if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) { + if (!gv) { + PL_laststatval = -1; + PL_laststype = OP_STAT; + } if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n')) Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); - RETPUSHUNDEF; + FT_RETURNUNDEF; } + PL_laststype = OP_STAT; PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache); if (PL_laststatval < 0) { (void)PerlIO_close(fp); - RETPUSHUNDEF; + FT_RETURNUNDEF; } PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL); len = PerlIO_read(fp, tbuf, sizeof(tbuf)); (void)PerlIO_close(fp); if (len <= 0) { if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT) - RETPUSHNO; /* special case NFS directories */ - RETPUSHYES; /* null file is anything */ + FT_RETURNNO; /* special case NFS directories */ + FT_RETURNYES; /* null file is anything */ } s = tbuf; } @@ -3529,9 +3469,9 @@ PP(pp_fttext) } if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */ - RETPUSHNO; + FT_RETURNNO; else - RETPUSHYES; + FT_RETURNYES; } /* File calls. */ @@ -3547,15 +3487,8 @@ PP(pp_chdir) if (PL_op->op_flags & OPf_SPECIAL) { gv = gv_fetchsv(sv, 0, SVt_PVIO); } - else if (isGV_with_GP(sv)) { - gv = MUTABLE_GV(sv); - } - else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) { - gv = MUTABLE_GV(SvRV(sv)); - } - else { - tmps = SvPV_nolen_const(sv); - } + else if (!(gv = MAYBE_DEREF_GV(sv))) + tmps = SvPV_nomg_const_nolen(sv); } if( !gv && (!tmps || !*tmps) ) { @@ -3591,15 +3524,13 @@ PP(pp_chdir) PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0); } else { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF, RMS_IFI); PUSHi(0); } } else { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); PUSHi(0); } @@ -3856,7 +3787,7 @@ PP(pp_mkdir) STRLEN len; const char *tmps; bool copy = FALSE; - const int mode = (MAXARG > 1) ? POPi : 0777; + const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777; TRIMSLASHES(tmps,len,copy); @@ -3911,8 +3842,8 @@ PP(pp_open_dir) if ((IoIFP(io) || IoOFP(io))) Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), - "Opening filehandle %s also as a directory", - GvENAME(gv)); + "Opening filehandle %"HEKf" also as a directory", + HEKfARG(GvENAME_HEK(gv)) ); if (IoDIRP(io)) PerlDir_close(IoDIRP(io)); if (!(IoDIRP(io) = PerlDir_open(dirname))) @@ -3947,7 +3878,8 @@ PP(pp_readdir) if (!io || !IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "readdir() attempted on invalid dirhandle %s", GvENAME(gv)); + "readdir() attempted on invalid dirhandle %"HEKf, + HEKfARG(GvENAME_HEK(gv))); goto nope; } @@ -3998,7 +3930,8 @@ PP(pp_telldir) if (!io || !IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "telldir() attempted on invalid dirhandle %s", GvENAME(gv)); + "telldir() attempted on invalid dirhandle %"HEKf, + HEKfARG(GvENAME_HEK(gv))); goto nope; } @@ -4023,7 +3956,8 @@ PP(pp_seekdir) if (!io || !IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "seekdir() attempted on invalid dirhandle %s", GvENAME(gv)); + "seekdir() attempted on invalid dirhandle %"HEKf, + HEKfARG(GvENAME_HEK(gv))); goto nope; } (void)PerlDir_seek(IoDIRP(io), along); @@ -4047,7 +3981,8 @@ PP(pp_rewinddir) if (!io || !IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv)); + "rewinddir() attempted on invalid dirhandle %"HEKf, + HEKfARG(GvENAME_HEK(gv))); goto nope; } (void)PerlDir_rewind(IoDIRP(io)); @@ -4070,7 +4005,8 @@ PP(pp_closedir) if (!io || !IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "closedir() attempted on invalid dirhandle %s", GvENAME(gv)); + "closedir() attempted on invalid dirhandle %"HEKf, + HEKfARG(GvENAME_HEK(gv))); goto nope; } #ifdef VOID_CLOSEDIR @@ -4107,12 +4043,6 @@ PP(pp_fork) if (childpid < 0) RETSETUNDEF; if (!childpid) { - GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV); - if (tmpgv) { - SvREADONLY_off(GvSV(tmpgv)); - sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); - SvREADONLY_on(GvSV(tmpgv)); - } #ifdef THREADS_HAVE_PIDS PL_ppid = (IV)getppid(); #endif @@ -4225,9 +4155,17 @@ PP(pp_system) Pid_t childpid; int pp[2]; I32 did_pipes = 0; +#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)) + sigset_t newset, oldset; +#endif if (PerlProc_pipe(pp) >= 0) did_pipes = 1; +#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)) + sigemptyset(&newset); + sigaddset(&newset, SIGCHLD); + sigprocmask(SIG_BLOCK, &newset, &oldset); +#endif while ((childpid = PerlProc_fork()) == -1) { if (errno != EAGAIN) { value = -1; @@ -4237,6 +4175,9 @@ PP(pp_system) PerlLIO_close(pp[0]); PerlLIO_close(pp[1]); } +#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)) + sigprocmask(SIG_SETMASK, &oldset, NULL); +#endif RETURN; } sleep(5); @@ -4255,6 +4196,9 @@ PP(pp_system) result = wait4pid(childpid, &status, 0); } while (result == -1 && errno == EINTR); #ifndef PERL_MICRO +#ifdef HAS_SIGPROCMASK + sigprocmask(SIG_SETMASK, &oldset, NULL); +#endif (void)rsignal_restore(SIGINT, &ihand); (void)rsignal_restore(SIGQUIT, &qhand); #endif @@ -4277,7 +4221,7 @@ PP(pp_system) PerlLIO_close(pp[0]); if (n) { /* Error */ if (n != sizeof(int)) - DIE(aTHX_ "panic: kid popen errno read"); + DIE(aTHX_ "panic: kid popen errno read, n=%u", n); errno = errkid; /* Propagate errno from kid */ STATUS_NATIVE_CHILD_SET(-1); } @@ -4285,6 +4229,9 @@ PP(pp_system) XPUSHi(STATUS_CURRENT); RETURN; } +#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)) + sigprocmask(SIG_SETMASK, &oldset, NULL); +#endif if (did_pipes) { PerlLIO_close(pp[0]); #if defined(HAS_FCNTL) && defined(F_SETFD) @@ -4408,7 +4355,8 @@ PP(pp_getpgrp) #ifdef HAS_GETPGRP dVAR; dSP; dTARGET; Pid_t pgrp; - const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs); + const Pid_t pid = + (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0); #ifdef BSD_GETPGRP pgrp = (I32)BSD_GETPGRP(pid); @@ -4430,15 +4378,12 @@ PP(pp_setpgrp) dVAR; dSP; dTARGET; Pid_t pgrp; Pid_t pid; - if (MAXARG < 2) { - pgrp = 0; + pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0; + if (MAXARG > 0) pid = TOPs && TOPi; + else { pid = 0; XPUSHi(-1); } - else { - pgrp = POPi; - pid = TOPi; - } TAINT_PROPER("setpgrp"); #ifdef BSD_SETPGRP @@ -4457,7 +4402,7 @@ PP(pp_setpgrp) #endif } -#ifdef __GLIBC__ +#if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2)) # define PRIORITY_WHICH_T(which) (__priority_which_t)which #else # define PRIORITY_WHICH_T(which) which @@ -4567,7 +4512,7 @@ PP(pp_gmtime) {"Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; - if (MAXARG < 1) { + if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) { time_t now; (void)time(&now); when = (Time64_T)now; @@ -4576,17 +4521,20 @@ PP(pp_gmtime) NV input = Perl_floor(POPn); when = (Time64_T)input; if (when != input) { + /* diag_listed_as: gmtime(%f) too large */ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), "%s(%.0" NVff ") too large", opname, input); } } if ( TIME_LOWER_BOUND > when ) { + /* diag_listed_as: gmtime(%f) too small */ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), "%s(%.0" NVff ") too small", opname, when); err = NULL; } else if( when > TIME_UPPER_BOUND ) { + /* diag_listed_as: gmtime(%f) too small */ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), "%s(%.0" NVff ") too large", opname, when); err = NULL; @@ -4667,7 +4615,7 @@ PP(pp_sleep) Time_t when; (void)time(&lasttime); - if (MAXARG < 1) + if (MAXARG < 1 || (!TOPs && !POPs)) PerlProc_pause(); else { duration = POPi; @@ -4707,7 +4655,7 @@ PP(pp_shmwrite) PUSHi(value); RETURN; #else - return pp_semget(); + return Perl_pp_semget(aTHX); #endif } @@ -4744,7 +4692,7 @@ PP(pp_semctl) } RETURN; #else - return pp_semget(); + return Perl_pp_semget(aTHX); #endif } @@ -4859,7 +4807,7 @@ PP(pp_ghostent) } RETURN; #else - DIE(aTHX_ PL_no_sock_func, "gethostent"); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif } @@ -4932,7 +4880,7 @@ PP(pp_gnetent) RETURN; #else - DIE(aTHX_ PL_no_sock_func, "getnetent"); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif } @@ -4992,7 +4940,7 @@ PP(pp_gprotoent) RETURN; #else - DIE(aTHX_ PL_no_sock_func, "getprotoent"); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif } @@ -5067,100 +5015,110 @@ PP(pp_gservent) RETURN; #else - DIE(aTHX_ PL_no_sock_func, "getservent"); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif } PP(pp_shostent) { -#ifdef HAS_SETHOSTENT dVAR; dSP; - PerlSock_sethostent(TOPi); - RETSETYES; + const int stayopen = TOPi; + switch(PL_op->op_type) { + case OP_SHOSTENT: +#ifdef HAS_SETHOSTENT + PerlSock_sethostent(stayopen); #else - DIE(aTHX_ PL_no_sock_func, "sethostent"); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif -} - -PP(pp_snetent) -{ + break; #ifdef HAS_SETNETENT - dVAR; dSP; - (void)PerlSock_setnetent(TOPi); - RETSETYES; + case OP_SNETENT: + PerlSock_setnetent(stayopen); #else - DIE(aTHX_ PL_no_sock_func, "setnetent"); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif -} - -PP(pp_sprotoent) -{ + break; + case OP_SPROTOENT: #ifdef HAS_SETPROTOENT - dVAR; dSP; - (void)PerlSock_setprotoent(TOPi); - RETSETYES; + PerlSock_setprotoent(stayopen); #else - DIE(aTHX_ PL_no_sock_func, "setprotoent"); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif -} - -PP(pp_sservent) -{ + break; + case OP_SSERVENT: #ifdef HAS_SETSERVENT - dVAR; dSP; - (void)PerlSock_setservent(TOPi); - RETSETYES; + PerlSock_setservent(stayopen); #else - DIE(aTHX_ PL_no_sock_func, "setservent"); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif + break; + } + RETSETYES; } PP(pp_ehostent) { -#ifdef HAS_ENDHOSTENT dVAR; dSP; - PerlSock_endhostent(); - EXTEND(SP,1); - RETPUSHYES; + switch(PL_op->op_type) { + case OP_EHOSTENT: +#ifdef HAS_ENDHOSTENT + PerlSock_endhostent(); #else - DIE(aTHX_ PL_no_sock_func, "endhostent"); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif -} - -PP(pp_enetent) -{ + break; + case OP_ENETENT: #ifdef HAS_ENDNETENT - dVAR; dSP; - PerlSock_endnetent(); - EXTEND(SP,1); - RETPUSHYES; + PerlSock_endnetent(); #else - DIE(aTHX_ PL_no_sock_func, "endnetent"); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif -} - -PP(pp_eprotoent) -{ + break; + case OP_EPROTOENT: #ifdef HAS_ENDPROTOENT - dVAR; dSP; - PerlSock_endprotoent(); - EXTEND(SP,1); - RETPUSHYES; + PerlSock_endprotoent(); #else - DIE(aTHX_ PL_no_sock_func, "endprotoent"); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif -} - -PP(pp_eservent) -{ + break; + case OP_ESERVENT: #ifdef HAS_ENDSERVENT - dVAR; dSP; - PerlSock_endservent(); - EXTEND(SP,1); - RETPUSHYES; + PerlSock_endservent(); #else - DIE(aTHX_ PL_no_sock_func, "endservent"); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif + break; + case OP_SGRENT: +#if defined(HAS_GROUP) && defined(HAS_SETGRENT) + setgrent(); +#else + DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); +#endif + break; + case OP_EGRENT: +#if defined(HAS_GROUP) && defined(HAS_ENDGRENT) + endgrent(); +#else + DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); +#endif + break; + case OP_SPWENT: +#if defined(HAS_PASSWD) && defined(HAS_SETPWENT) + setpwent(); +#else + DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); +#endif + break; + case OP_EPWENT: +#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT) + endpwent(); +#else + DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); +#endif + break; + } + EXTEND(SP,1); + RETPUSHYES; } PP(pp_gpwent) @@ -5306,7 +5264,7 @@ PP(pp_gpwent) const struct spwd * const spwent = getspnam(pwent->pw_name); /* Save and restore errno so that * underprivileged attempts seem - * to have never made the unsccessful + * to have never made the unsuccessful * attempt to retrieve the shadow password. */ RESTORE_ERRNO; if (spwent && spwent->sp_pwdp) @@ -5396,28 +5354,6 @@ PP(pp_gpwent) #endif } -PP(pp_spwent) -{ -#if defined(HAS_PASSWD) && defined(HAS_SETPWENT) - dVAR; dSP; - setpwent(); - RETPUSHYES; -#else - DIE(aTHX_ PL_no_func, "setpwent"); -#endif -} - -PP(pp_epwent) -{ -#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT) - dVAR; dSP; - endpwent(); - RETPUSHYES; -#else - DIE(aTHX_ PL_no_func, "endpwent"); -#endif -} - PP(pp_ggrent) { #ifdef HAS_GROUP @@ -5492,28 +5428,6 @@ PP(pp_ggrent) #endif } -PP(pp_sgrent) -{ -#if defined(HAS_GROUP) && defined(HAS_SETGRENT) - dVAR; dSP; - setgrent(); - RETPUSHYES; -#else - DIE(aTHX_ PL_no_func, "setgrent"); -#endif -} - -PP(pp_egrent) -{ -#if defined(HAS_GROUP) && defined(HAS_ENDGRENT) - dVAR; dSP; - endgrent(); - RETPUSHYES; -#else - DIE(aTHX_ PL_no_func, "endgrent"); -#endif -} - PP(pp_getlogin) { #ifdef HAS_GETLOGIN