X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e3918bb703cafa92e5a8d957a810cafe3334d9a1..dc83bf8e644104953efa0f771ec775aba638af5a:/pp_sys.c?ds=sidebyside diff --git a/pp_sys.c b/pp_sys.c index 54fe661..dc1b3ce 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -30,7 +30,6 @@ #define PERL_IN_PP_SYS_C #include "perl.h" #include "time64.h" -#include "time64.c" #ifdef I_SHADOW /* Shadow password support for solaris - pdo@cs.umd.edu @@ -179,10 +178,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 +290,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 +351,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; } @@ -398,7 +393,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 +410,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 +439,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 +465,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 +485,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; @@ -531,9 +533,9 @@ Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv, 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); + STATIC_ASSERT_STMT((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0); + STATIC_ASSERT_STMT((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0); + STATIC_ASSERT_STMT((TIED_METHOD_SAY & G_WANT) == 0); PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */ PUSHSTACKi(PERLSI_MAGIC); @@ -566,7 +568,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 +592,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 +619,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 +633,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 +646,7 @@ PP(pp_open) PP(pp_close) { - dVAR; dSP; + dSP; GV * const gv = MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs); @@ -656,7 +658,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,7 +669,6 @@ PP(pp_close) PP(pp_pipe_op) { #ifdef HAS_PIPE - dVAR; dSP; IO *rstio; IO *wstio; @@ -676,16 +677,13 @@ PP(pp_pipe_op) GV * const wgv = MUTABLE_GV(POPs); GV * const rgv = MUTABLE_GV(POPs); - if (!rgv || !wgv) - goto badexit; - - if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv)) - DIE(aTHX_ PL_no_usym, "filehandle"); + assert (isGV_with_GP(rgv)); + assert (isGV_with_GP(wgv)); rstio = GvIOn(rgv); - wstio = GvIOn(wgv); - if (IoIFP(rstio)) do_close(rgv, FALSE); + + wstio = GvIOn(wgv); if (IoIFP(wstio)) do_close(wgv, FALSE); @@ -711,12 +709,14 @@ 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; -badexit: + badexit: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_func, "pipe"); @@ -725,7 +725,7 @@ badexit: PP(pp_fileno) { - dVAR; dSP; dTARGET; + dSP; dTARGET; GV *gv; IO *io; PerlIO *fp; @@ -739,7 +739,23 @@ 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 && IoDIRP(io)) { +#if defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD) + PUSHi(my_dirfd(IoDIRP(io))); + RETURN; +#elif defined(ENOTSUP) + errno = ENOTSUP; /* Operation not supported */ + RETPUSHUNDEF; +#elif defined(EOPNOTSUPP) + errno = EOPNOTSUPP; /* Operation not supported on socket */ + RETPUSHUNDEF; +#else + errno = EINVAL; /* Invalid argument */ + RETPUSHUNDEF; +#endif } if (!io || !(fp = IoIFP(io))) { @@ -757,7 +773,6 @@ PP(pp_fileno) PP(pp_umask) { - dVAR; dSP; #ifdef HAS_UMASK dTARGET; @@ -788,7 +803,7 @@ PP(pp_umask) PP(pp_binmode) { - dVAR; dSP; + dSP; GV *gv; IO *io; PerlIO *fp; @@ -810,7 +825,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 +864,7 @@ PP(pp_binmode) PP(pp_tie) { - dVAR; dSP; dMARK; + dSP; dMARK; HV* stash; GV *gv = NULL; SV *sv; @@ -893,7 +908,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; @@ -950,9 +969,12 @@ PP(pp_tie) RETURN; } + +/* also used for: pp_dbmclose() */ + PP(pp_untie) { - dVAR; dSP; + dSP; MAGIC *mg; SV *sv = POPs; const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) @@ -961,6 +983,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) { @@ -989,26 +1014,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; @@ -1052,9 +1081,11 @@ PP(pp_dbmopen) PUTBACK; call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR); SPAGAIN; + if (sv_isobject(TOPs)) + goto retie; } - - if (sv_isobject(TOPs)) { + else { + retie: sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied); sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0); } @@ -1065,7 +1096,7 @@ PP(pp_dbmopen) PP(pp_sselect) { #ifdef HAS_SELECT - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 i; I32 j; char *s; @@ -1096,10 +1127,11 @@ PP(pp_sselect) SvGETMAGIC(sv); if (!SvOK(sv)) continue; - if (SvIsCOW(sv)) - sv_force_normal_flags(sv, 0); - if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0)) + if (SvREADONLY(sv)) { + if (!(SvPOK(sv) && SvCUR(sv) == 0)) Perl_croak_no_modify(); + } + else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); if (!SvPOK(sv)) { if (!SvPOKp(sv)) Perl_ck_warner(aTHX_ packWARN(WARN_MISC), @@ -1136,14 +1168,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; @@ -1215,7 +1248,7 @@ PP(pp_sselect) } PUSHi(nfound); - if (GIMME == G_ARRAY && tbuf) { + if (GIMME_V == G_ARRAY && tbuf) { value = (NV)(timebuf.tv_sec) + (NV)(timebuf.tv_usec) / 1000000.0; mPUSHn(value); @@ -1227,10 +1260,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. @@ -1240,7 +1276,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); @@ -1249,7 +1284,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); @@ -1280,7 +1315,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); @@ -1292,7 +1327,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); @@ -1319,6 +1354,7 @@ PP(pp_getc) } SvUTF8_on(TARG); } + else SvUTF8_off(TARG); PUSHTARG; RETURN; } @@ -1326,13 +1362,12 @@ PP(pp_getc) STATIC OP * S_doform(pTHX_ CV *cv, GV *gv, OP *retop) { - dVAR; 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; @@ -1353,7 +1388,6 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) PP(pp_enterwrite) { - dVAR; dSP; GV *gv; IO *io; @@ -1362,8 +1396,8 @@ PP(pp_enterwrite) SV *tmpsv = NULL; if (MAXARG == 0) { - gv = PL_defoutgv; EXTEND(SP, 1); + gv = PL_defoutgv; } else { gv = MUTABLE_GV(POPs); @@ -1393,7 +1427,7 @@ PP(pp_enterwrite) PP(pp_leavewrite) { - dVAR; dSP; + dSP; GV * const gv = cxstack[cxstack_ix].blk_format.gv; IO * const io = GvIOp(gv); PerlIO *ofp; @@ -1402,8 +1436,9 @@ PP(pp_leavewrite) I32 gimme; PERL_CONTEXT *cx; OP *retop; + bool is_return = cBOOL(PL_op->op_type == OP_RETURN); - if (!io || !(ofp = IoOFP(io))) + if (is_return || !io || !(ofp = IoOFP(io))) goto forget_top; DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n", @@ -1464,8 +1499,7 @@ PP(pp_leavewrite) PL_formtarget = PL_toptarget; IoFLAGS(io) |= IOf_DIDTOP; fgv = IoTOP_GV(io); - if (!fgv) - DIE(aTHX_ "bad top format reference"); + assert(fgv); /* IoTOP_GV(io) should have been set above */ cv = GvFORM(fgv); if (!cv) { SV * const sv = sv_newmortal(); @@ -1477,12 +1511,18 @@ PP(pp_leavewrite) forget_top: POPBLOCK(cx,PL_curpm); - POPFORMAT(cx); retop = cx->blk_sub.retop; + POPFORMAT(cx); SP = newsp; /* ignore retval of formline */ LEAVE; - if (!io || !(fp = IoOFP(io))) { + if (is_return) + /* XXX the semantics of doing 'return' in a format aren't documented. + * Currently we ignore any args to 'return' and just return + * a single undef in both scalar and list contexts + */ + PUSHs(&PL_sv_undef); + else if (!io || !(fp = IoOFP(io))) { if (io && IoIFP(io)) report_wrongway_fh(gv, '<'); else @@ -1511,7 +1551,7 @@ PP(pp_leavewrite) PP(pp_prtf) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; PerlIO *fp; GV * const gv @@ -1530,7 +1570,7 @@ PP(pp_prtf) Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); ++SP; } - return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io), + return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io), mg, G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, sp - mark); @@ -1572,7 +1612,6 @@ PP(pp_prtf) PP(pp_sysopen) { - dVAR; dSP; const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666; const int mode = POPi; @@ -1582,8 +1621,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); } @@ -1593,9 +1631,12 @@ PP(pp_sysopen) RETURN; } + +/* also used for: pp_read() and pp_recv() (where supported) */ + PP(pp_sysread) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; SSize_t offset; IO *io; char *buffer; @@ -1612,14 +1653,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); } @@ -1644,7 +1686,16 @@ 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) { + if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) { + Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED), + "%s() is deprecated on :utf8 handles", + OP_DESC(PL_op)); + } buffer = SvPVutf8_force(bufsv, blen); /* UTF-8 may not have been set if they are all low bytes */ SvUTF8_on(bufsv); @@ -1667,6 +1718,10 @@ PP(pp_sysread) if (PL_op->op_type == OP_RECV) { Sock_size_t bufsize; char namebuf[MAXPATHLEN]; + if (fd < 0) { + SETERRNO(EBADF,SS_IVCHAN); + RETPUSHUNDEF; + } #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__) bufsize = sizeof (struct sockaddr_in); #else @@ -1678,17 +1733,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); @@ -1699,6 +1750,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; @@ -1716,13 +1775,17 @@ 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 unduly. (should be 2 * length + offset + 1, or possibly something longer if - PL_encoding is true) */ + IN_ENCODING Is true) */ buffer = SvGROW(bufsv, (STRLEN)(length+offset+1)); if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */ Zero(buffer+orig_size, offset-orig_size, char); @@ -1746,31 +1809,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 */ @@ -1838,9 +1895,12 @@ PP(pp_sysread) RETPUSHUNDEF; } + +/* also used for: pp_send() where defined */ + PP(pp_syswrite) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; SV *bufsv; const char *buffer; SSize_t retval; @@ -1851,6 +1911,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); @@ -1861,7 +1922,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); } @@ -1881,6 +1942,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); @@ -1888,6 +1955,9 @@ PP(pp_syswrite) doing_utf8 = DO_UTF8(bufsv); if (PerlIO_isutf8(IoIFP(io))) { + Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED), + "%s() is deprecated on :utf8 handles", + OP_DESC(PL_op)); if (!SvUTF8(bufsv)) { /* We don't modify the original scalar. */ tmpbuf = bytes_to_utf8((const U8*) buffer, &blen); @@ -1915,12 +1985,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 @@ -2003,15 +2072,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); } } @@ -2037,7 +2104,7 @@ PP(pp_syswrite) PP(pp_eof) { - dVAR; dSP; + dSP; GV *gv; IO *io; const MAGIC *mg; @@ -2074,22 +2141,26 @@ 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) { + SV ** svp; IoLINES(io) = 0; IoFLAGS(io) &= ~IOf_START; - do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL); - if (GvSV(gv)) - sv_setpvs(GvSV(gv), "-"); + do_open6(gv, "-", 1, NULL, NULL, 0); + svp = &GvSV(gv); + if (*svp) { + SV * sv = *svp; + sv_setpvs(sv, "-"); + SvSETMAGIC(sv); + } else - GvSV(gv) = newSVpvs("-"); - SvSETMAGIC(GvSV(gv)); + *svp = newSVpvs("-"); } - else if (!nextargv(gv)) + else if (!nextargv(gv, FALSE)) RETPUSHYES; } } @@ -2100,7 +2171,7 @@ PP(pp_eof) PP(pp_tell) { - dVAR; dSP; dTARGET; + dSP; dTARGET; GV *gv; IO *io; @@ -2114,7 +2185,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) { @@ -2132,9 +2203,12 @@ PP(pp_tell) RETURN; } + +/* also used for: pp_seek() */ + PP(pp_sysseek) { - dVAR; dSP; + dSP; const int whence = POPi; #if LSEEKSIZE > IVSIZE const Off_t offset = (Off_t)SvNVx(POPs); @@ -2154,7 +2228,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)); } } @@ -2181,7 +2255,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 @@ -2219,13 +2292,24 @@ PP(pp_truncate) result = 0; } else { - PerlIO_flush(fp); + int fd = PerlIO_fileno(fp); + if (fd < 0) { + SETERRNO(EBADF,RMS_IFI); + result = 0; + } else { + if (len < 0) { + SETERRNO(EINVAL, LIB_INVARG); + 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; + } + } } } } @@ -2241,11 +2325,24 @@ PP(pp_truncate) result = 0; #else { - const int tmpfd = PerlLIO_open(name, O_RDWR); + int mode = O_RDWR; + int tmpfd; - if (tmpfd < 0) +#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) + mode |= O_LARGEFILE; /* Transparently largefiley. */ +#endif +#ifdef O_BINARY + /* On open(), the Win32 CRT tries to seek around text + * files using 32-bit offsets, which causes the open() + * to fail on large files, so open in binary mode. + */ + mode |= O_BINARY; +#endif + tmpfd = PerlLIO_open(name, mode); + + if (tmpfd < 0) { result = 0; - else { + } else { if (my_chsize(tmpfd, len) < 0) result = 0; PerlLIO_close(tmpfd); @@ -2262,18 +2359,21 @@ PP(pp_truncate) } } + +/* also used for: pp_fcntl() */ + 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; @@ -2296,6 +2396,7 @@ PP(pp_ioctl) s = INT2PTR(char*,retval); /* ouch */ } + optype = PL_op->op_type; TAINT_PROPER(PL_op_desc[optype]); if (optype == OP_IOCTL) @@ -2339,7 +2440,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); @@ -2359,7 +2460,7 @@ PP(pp_flock) PUSHi(value); RETURN; #else - DIE(aTHX_ PL_no_func, "flock()"); + DIE(aTHX_ PL_no_func, "flock"); #endif } @@ -2369,29 +2470,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); - 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; @@ -2402,11 +2497,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; @@ -2416,29 +2508,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); - IO * const io1 = gv1 ? GvIOn(gv1) : NULL; - IO * const io2 = gv2 ? GvIOn(gv2) : NULL; - int fd[2]; + IO * const io1 = GvIOn(gv1); - if (!io1) - report_evil_fh(gv1); - if (!io2) - report_evil_fh(gv2); - - if (io1 && IoIFP(io1)) + if (IoIFP(io1)) do_close(gv1, FALSE); - if (io2 && IoIFP(io2)) + if (IoIFP(io2)) do_close(gv2, FALSE); - if (!io1 || !io2) - RETPUSHUNDEF; - TAINT_PROPER("socketpair"); if (PerlSock_socketpair(domain, type, protocol, fd) < 0) RETPUSHUNDEF; @@ -2458,8 +2543,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; @@ -2470,31 +2557,38 @@ PP(pp_sockpair) #ifdef HAS_SOCKET +/* also used for: pp_connect() */ + 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); 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 RETPUSHUNDEF; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; @@ -2502,12 +2596,12 @@ nuts: PP(pp_listen) { - dVAR; dSP; + dSP; const int backlog = POPi; GV * const gv = MUTABLE_GV(POPs); - IO * const io = gv ? GvIOn(gv) : NULL; + IO * const io = GvIOn(gv); - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0) @@ -2515,7 +2609,7 @@ PP(pp_listen) else RETPUSHUNDEF; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; @@ -2523,9 +2617,8 @@ nuts: PP(pp_accept) { - dVAR; dSP; dTARGET; + dSP; dTARGET; IO *nstio; - IO *gstio; char namebuf[MAXPATHLEN]; #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__) Sock_size_t len = sizeof (struct sockaddr_in); @@ -2536,12 +2629,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; @@ -2572,13 +2660,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 @@ -2586,37 +2671,40 @@ PP(pp_accept) PUSHp(namebuf, len); RETURN; -nuts: + nuts: report_evil_fh(ggv); SETERRNO(EBADF,SS_IVCHAN); -badexit: + badexit: RETPUSHUNDEF; } PP(pp_shutdown) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const int how = POPi; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 ); RETURN; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; } + +/* also used for: pp_gsockopt() */ + 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; @@ -2626,10 +2714,12 @@ PP(pp_ssockopt) int fd; Sock_size_t len; - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) + goto nuts; switch (optype) { case OP_GSOCKOPT: SvGROW(sv, 257); @@ -2639,6 +2729,11 @@ PP(pp_ssockopt) len = SvCUR(sv); if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0) goto nuts2; +#if defined(_AIX) + /* XXX Configure test: does getsockopt set the length properly? */ + if (len == 256) + len = sizeof(int); +#endif SvCUR_set(sv, len); *SvEND(sv) ='\0'; PUSHs(sv); @@ -2678,17 +2773,20 @@ PP(pp_ssockopt) } RETURN; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); -nuts2: + nuts2: RETPUSHUNDEF; } + +/* also used for: pp_getsockname() */ + PP(pp_getpeername) { - dVAR; dSP; + dSP; const int optype = PL_op->op_type; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); @@ -2696,7 +2794,7 @@ PP(pp_getpeername) SV *sv; int fd; - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; sv = sv_2mortal(newSV(257)); @@ -2705,6 +2803,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) @@ -2737,10 +2837,10 @@ PP(pp_getpeername) PUSHs(sv); RETURN; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); -nuts2: + nuts2: RETPUSHUNDEF; } @@ -2748,9 +2848,10 @@ nuts2: /* Stat calls. */ +/* also used for: pp_lstat() */ + PP(pp_stat) { - dVAR; dSP; GV *gv = NULL; IO *io = NULL; @@ -2786,9 +2887,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); @@ -2806,6 +2912,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) @@ -2817,13 +2924,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; } } @@ -2849,24 +2961,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 @@ -2953,7 +3051,6 @@ S_ft_return_true(pTHX_ SV *ret) { STATIC OP * S_try_amagic_ftest(pTHX_ char chr) { - dVAR; SV *const arg = *PL_stack_sp; assert(chr != '?'); @@ -2976,12 +3073,14 @@ S_try_amagic_ftest(pTHX_ char chr) { } +/* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec() + * pp_ftrwrite() */ + 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. */ @@ -3040,7 +3139,7 @@ PP(pp_ftrread) access_mode = W_OK; #endif stat_mode = S_IWUSR; - /* fall through */ + /* FALLTHROUGH */ case OP_FTEREAD: #ifndef PERL_EFF_ACCESS @@ -3094,9 +3193,11 @@ PP(pp_ftrread) FT_RETURNNO; } + +/* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */ + PP(pp_ftis) { - dVAR; I32 result; const int op_type = PL_op->op_type; char opchar = '?'; @@ -3146,9 +3247,13 @@ PP(pp_ftis) } } + +/* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned() + * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock() + * pp_ftsuid() pp_ftsvtx() pp_ftzero() */ + PP(pp_ftrowned) { - dVAR; I32 result; char opchar = '?'; @@ -3250,7 +3355,6 @@ PP(pp_ftrowned) PP(pp_ftlink) { - dVAR; I32 result; tryAMAGICftest_MG('l'); @@ -3265,11 +3369,11 @@ PP(pp_ftlink) PP(pp_fttty) { - dVAR; int fd; GV *gv; char *name = NULL; STRLEN namelen; + UV uv; tryAMAGICftest_MG('t'); @@ -3285,20 +3389,26 @@ PP(pp_fttty) if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); - else if (name && isDIGIT(*name)) - fd = atoi(name); + else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX) + fd = (int)uv; else FT_RETURNUNDEF; + if (fd < 0) { + SETERRNO(EBADF,RMS_IFI); + FT_RETURNUNDEF; + } if (PerlLIO_isatty(fd)) FT_RETURNYES; FT_RETURNNO; } + +/* also used for: pp_ftbinary() */ + PP(pp_fttext) { - dVAR; I32 i; - I32 len; + SSize_t len; I32 odd = 0; STDCHAR tbuf[512]; STDCHAR *s; @@ -3337,9 +3447,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 */ @@ -3352,9 +3468,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 */ @@ -3369,23 +3486,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); @@ -3400,7 +3532,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 */ @@ -3408,43 +3539,53 @@ PP(pp_fttext) --len; #endif + assert(len); + if (! is_invariant_string((U8 *) s, len)) { + const U8 *ep; + + /* Here contains a variant under UTF-8 . 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 */ @@ -3457,7 +3598,7 @@ PP(pp_fttext) PP(pp_chdir) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const char *tmps = NULL; GV *gv = NULL; @@ -3465,12 +3606,21 @@ PP(pp_chdir) SV * const sv = POPs; if (PL_op->op_flags & OPf_SPECIAL) { gv = gv_fetchsv(sv, 0, SVt_PVIO); + if (!gv) { + if (ckWARN(WARN_UNOPENED)) { + Perl_warner(aTHX_ packWARN(WARN_UNOPENED), + "chdir() on unopened filehandle %" SVf, sv); + } + SETERRNO(EBADF,RMS_IFI); + PUSHi(0); + TAINT_PROPER("chdir"); + RETURN; + } } else if (!(gv = MAYBE_DEREF_GV(sv))) tmps = SvPV_nomg_const_nolen(sv); } - - if( !gv && (!tmps || !*tmps) ) { + else { HV * const table = GvHVn(PL_envgv); SV **svp; @@ -3481,12 +3631,11 @@ PP(pp_chdir) #endif ) { - if( MAXARG == 1 ) - deprecate("chdir('') or chdir(undef) as chdir()"); tmps = SvPV_nolen_const(*svp); } else { PUSHi(0); + SETERRNO(EINVAL, LIB_INVARG); TAINT_PROPER("chdir"); RETURN; } @@ -3500,19 +3649,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 @@ -3525,11 +3674,22 @@ PP(pp_chdir) hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD); #endif RETURN; + +#ifdef HAS_FCHDIR + nuts: + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); + PUSHi(0); + RETURN; +#endif } + +/* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */ + PP(pp_chown) { - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; const I32 value = (I32)apply(PL_op->op_type, MARK, SP); SP = MARK; @@ -3540,7 +3700,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 ); @@ -3552,7 +3712,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); @@ -3575,10 +3735,13 @@ PP(pp_rename) RETURN; } + +/* also used for: pp_symlink() */ + #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; @@ -3617,6 +3780,9 @@ PP(pp_link) RETURN; } #else + +/* also used for: pp_symlink() */ + PP(pp_link) { /* Have neither. */ @@ -3626,21 +3792,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 @@ -3688,13 +3855,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)) { @@ -3762,11 +3923,11 @@ 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; - const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777; + const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777; TRIMSLASHES(tmps,len,copy); @@ -3789,7 +3950,7 @@ PP(pp_mkdir) PP(pp_rmdir) { - dVAR; dSP; dTARGET; + dSP; dTARGET; STRLEN len; const char *tmps; bool copy = FALSE; @@ -3811,14 +3972,11 @@ 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); IO * const io = GvIOn(gv); - if (!io) - goto nope; - if ((IoIFP(io) || IoOFP(io))) Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), "Opening filehandle %"HEKf" also as a directory", @@ -3829,7 +3987,7 @@ PP(pp_open_dir) goto nope; RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_DIR); RETPUSHUNDEF; @@ -3846,16 +4004,15 @@ PP(pp_readdir) #if !defined(I_DIRENT) && !defined(VMS) Direntry_t *readdir (DIR *); #endif - dVAR; dSP; SV *sv; - const I32 gimme = GIMME; + const I32 gimme = GIMME_V; GV * const gv = MUTABLE_GV(POPs); 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))); @@ -3871,22 +4028,20 @@ 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; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); - if (GIMME == G_ARRAY) + if (gimme == G_ARRAY) RETURN; else RETPUSHUNDEF; @@ -3896,7 +4051,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. @@ -3907,7 +4062,7 @@ PP(pp_telldir) GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io || !IoDIRP(io)) { + if (!IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), "telldir() attempted on invalid dirhandle %"HEKf, HEKfARG(GvENAME_HEK(gv))); @@ -3916,7 +4071,7 @@ PP(pp_telldir) PUSHi( PerlDir_tell(IoDIRP(io)) ); RETURN; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; @@ -3928,12 +4083,12 @@ nope: PP(pp_seekdir) { #if defined(HAS_SEEKDIR) || defined(seekdir) - dVAR; dSP; + dSP; const long along = POPl; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io || !IoDIRP(io)) { + if (!IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), "seekdir() attempted on invalid dirhandle %"HEKf, HEKfARG(GvENAME_HEK(gv))); @@ -3942,7 +4097,7 @@ PP(pp_seekdir) (void)PerlDir_seek(IoDIRP(io), along); RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; @@ -3954,11 +4109,11 @@ nope: PP(pp_rewinddir) { #if defined(HAS_REWINDDIR) || defined(rewinddir) - dVAR; dSP; + dSP; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io || !IoDIRP(io)) { + if (!IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), "rewinddir() attempted on invalid dirhandle %"HEKf, HEKfARG(GvENAME_HEK(gv))); @@ -3966,7 +4121,7 @@ PP(pp_rewinddir) } (void)PerlDir_rewind(IoDIRP(io)); RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; @@ -3978,11 +4133,11 @@ nope: PP(pp_closedir) { #if defined(Direntry_t) && defined(HAS_READDIR) - dVAR; dSP; + dSP; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io || !IoDIRP(io)) { + if (!IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), "closedir() attempted on invalid dirhandle %"HEKf, HEKfARG(GvENAME_HEK(gv))); @@ -3999,7 +4154,7 @@ PP(pp_closedir) IoDIRP(io) = 0; RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; @@ -4013,15 +4168,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 @@ -4033,7 +4188,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); @@ -4070,7 +4225,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; @@ -4098,7 +4253,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; @@ -4127,7 +4282,7 @@ PP(pp_waitpid) PP(pp_system) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; #if defined(__LIBCATAMOUNT__) PL_statusvalue = -1; SP = ORIGMARK; @@ -4152,13 +4307,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); @@ -4172,7 +4327,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; @@ -4226,13 +4381,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) { @@ -4280,7 +4436,7 @@ PP(pp_system) PP(pp_exec) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; I32 value; if (TAINTING_get) { @@ -4320,7 +4476,7 @@ PP(pp_exec) PP(pp_getppid) { #ifdef HAS_GETPPID - dVAR; dSP; dTARGET; + dSP; dTARGET; XPUSHi( getppid() ); RETURN; #else @@ -4331,7 +4487,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); @@ -4346,21 +4502,22 @@ 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; - if (MAXARG > 0) pid = TOPs && TOPi; + if (MAXARG > 0) pid = TOPs ? TOPi : 0; else { pid = 0; - XPUSHi(-1); + EXTEND(SP,1); + SP++; } TAINT_PROPER("setpgrp"); @@ -4376,7 +4533,7 @@ PP(pp_setpgrp) #endif /* USE_BSDPGRP */ RETURN; #else - DIE(aTHX_ PL_no_func, "setpgrp()"); + DIE(aTHX_ PL_no_func, "setpgrp"); #endif } @@ -4389,20 +4546,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; @@ -4410,7 +4567,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 } @@ -4420,7 +4577,7 @@ PP(pp_setpriority) PP(pp_time) { - dVAR; dSP; dTARGET; + dSP; dTARGET; #ifdef BIG_TIME XPUSHn( time(NULL) ); #else @@ -4432,22 +4589,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); - 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_utime)/(NV)PL_clocktick); + if (GIMME_V == G_ARRAY) { + 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 @@ -4455,7 +4607,7 @@ PP(pp_tms) dSP; mPUSHn(0.0); EXTEND(SP, 4); - if (GIMME == G_ARRAY) { + if (GIMME_V == G_ARRAY) { mPUSHn(0.0); mPUSHn(0.0); mPUSHn(0.0); @@ -4476,9 +4628,11 @@ PP(pp_tms) /* Sun Dec 29 12:00:00 2147483647 */ #define TIME_UPPER_BOUND 67767976233316800.0 + +/* also used for: pp_localtime() */ + PP(pp_gmtime) { - dVAR; dSP; Time64_T when; struct TM tmbuf; @@ -4497,11 +4651,16 @@ PP(pp_gmtime) } else { NV input = Perl_floor(POPn); + const bool pl_isnan = Perl_isnan(input); when = (Time64_T)input; - if (when != input) { + if (UNLIKELY(pl_isnan || when != input)) { /* diag_listed_as: gmtime(%f) too large */ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), "%s(%.0" NVff ") too large", opname, input); + if (pl_isnan) { + err = NULL; + goto failed; + } } } @@ -4519,36 +4678,35 @@ PP(pp_gmtime) } else { if (PL_op->op_type == OP_LOCALTIME) - err = S_localtime64_r(&when, &tmbuf); + err = Perl_localtime64_r(&when, &tmbuf); else - err = S_gmtime64_r(&when, &tmbuf); + err = Perl_gmtime64_r(&when, &tmbuf); } if (err == NULL) { + /* diag_listed_as: gmtime(%f) failed */ /* XXX %lld broken for quads */ + failed: 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; - + if (GIMME_V != G_ARRAY) { /* scalar context */ 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 { + dTARGET; + PUSHs(TARG); + Perl_sv_setpvf_mg(aTHX_ TARG, "%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 ) @@ -4572,14 +4730,31 @@ PP(pp_gmtime) PP(pp_alarm) { #ifdef HAS_ALARM - dVAR; dSP; dTARGET; - int anum; - anum = POPi; - anum = alarm((unsigned int)anum); - if (anum < 0) - RETPUSHUNDEF; - PUSHi(anum); - RETURN; + dSP; dTARGET; + /* alarm() takes an unsigned int number of seconds, and return the + * unsigned int number of seconds remaining in the previous alarm + * (alarms don't stack). Therefore negative return values are not + * possible. */ + int anum = POPi; + if (anum < 0) { + /* Note that while the C library function alarm() as such has + * no errors defined (or in other words, properly behaving client + * code shouldn't expect any), alarm() being obsoleted by + * setitimer() and often being implemented in terms of + * setitimer(), can fail. */ + /* diag_listed_as: %s() with negative argument */ + Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC), + "alarm() with negative argument"); + SETERRNO(EINVAL, LIB_INVARG); + RETPUSHUNDEF; + } + else { + unsigned int retval = alarm(anum); + if ((int)retval < 0) /* Strictly speaking "cannot happen". */ + RETPUSHUNDEF; + PUSHu(retval); + RETURN; + } #else DIE(aTHX_ PL_no_func, "alarm"); #endif @@ -4587,7 +4762,7 @@ PP(pp_alarm) PP(pp_sleep) { - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 duration; Time_t lasttime; Time_t when; @@ -4597,7 +4772,16 @@ PP(pp_sleep) PerlProc_pause(); else { duration = POPi; - PerlProc_sleep((unsigned int)duration); + if (duration < 0) { + /* diag_listed_as: %s() with negative argument */ + Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC), + "sleep() with negative argument"); + SETERRNO(EINVAL, LIB_INVARG); + XPUSHi(0); + RETURN; + } else { + PerlProc_sleep((unsigned int)duration); + } } (void)time(&when); XPUSHi(when - lasttime); @@ -4607,10 +4791,12 @@ PP(pp_sleep) /* Shared memory. */ /* Merged with some message passing. */ +/* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */ + 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; @@ -4639,10 +4825,12 @@ PP(pp_shmwrite) /* Semaphores. */ +/* also used for: pp_msgget() pp_shmget() */ + 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) @@ -4654,14 +4842,16 @@ PP(pp_semget) #endif } +/* also used for: pp_msgctl() pp_shmctl() */ + 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) - RETSETUNDEF; + RETPUSHUNDEF; if (anum != 0) { PUSHi(anum); } @@ -4683,7 +4873,7 @@ S_space_join_names_mortal(pTHX_ char *const *array) PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL; - if (array && *array) { + if (*array) { target = newSVpvs_flags("", SVs_TEMP); while (1) { sv_catpv(target, *array); @@ -4699,10 +4889,12 @@ S_space_join_names_mortal(pTHX_ char *const *array) /* Get system info. */ +/* also used for: pp_ghbyaddr() pp_ghbyname() */ + PP(pp_ghostent) { #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; char **elem; SV *sv; @@ -4753,7 +4945,7 @@ PP(pp_ghostent) } #endif - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { PUSHs(sv = sv_newmortal()); if (hent) { if (which == OP_GHBYNAME) { @@ -4789,10 +4981,12 @@ PP(pp_ghostent) #endif } +/* also used for: pp_gnbyaddr() pp_gnbyname() */ + PP(pp_gnetent) { #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; SV *sv; #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */ @@ -4838,7 +5032,7 @@ PP(pp_gnetent) #endif EXTEND(SP, 4); - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { PUSHs(sv = sv_newmortal()); if (nent) { if (which == OP_GNBYNAME) @@ -4862,10 +5056,13 @@ PP(pp_gnetent) #endif } + +/* also used for: pp_gpbyname() pp_gpbynumber() */ + PP(pp_gprotoent) { #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; SV *sv; #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */ @@ -4899,7 +5096,7 @@ PP(pp_gprotoent) #endif EXTEND(SP, 3); - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { PUSHs(sv = sv_newmortal()); if (pent) { if (which == OP_GPBYNAME) @@ -4922,10 +5119,13 @@ PP(pp_gprotoent) #endif } + +/* also used for: pp_gsbyname() pp_gsbyport() */ + PP(pp_gservent) { #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; SV *sv; #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */ @@ -4948,9 +5148,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"); @@ -4964,15 +5162,11 @@ PP(pp_gservent) #endif EXTEND(SP, 4); - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { 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); @@ -4983,11 +5177,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)); } @@ -4997,9 +5187,12 @@ PP(pp_gservent) #endif } + +/* also used for: pp_snetent() pp_sprotoent() pp_sservent() */ + PP(pp_shostent) { - dVAR; dSP; + dSP; const int stayopen = TOPi; switch(PL_op->op_type) { case OP_SHOSTENT: @@ -5034,9 +5227,13 @@ PP(pp_shostent) RETSETYES; } + +/* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent() + * pp_eservent() pp_sgrent() pp_spwent() */ + PP(pp_ehostent) { - dVAR; dSP; + dSP; switch(PL_op->op_type) { case OP_EHOSTENT: #ifdef HAS_ENDHOSTENT @@ -5099,10 +5296,13 @@ PP(pp_ehostent) RETPUSHYES; } + +/* also used for: pp_gpwnam() pp_gpwuid() */ + PP(pp_gpwent) { #ifdef HAS_PASSWD - dVAR; dSP; + dSP; I32 which = PL_op->op_type; SV *sv; struct passwd *pwent = NULL; @@ -5198,15 +5398,11 @@ PP(pp_gpwent) } EXTEND(SP, 10); - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { 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); } @@ -5254,23 +5450,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. @@ -5309,18 +5495,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); @@ -5332,10 +5514,13 @@ PP(pp_gpwent) #endif } + +/* also used for: pp_ggrgid() pp_ggrnam() */ + PP(pp_ggrent) { #ifdef HAS_GROUP - dVAR; dSP; + dSP; const I32 which = PL_op->op_type; const struct group *grent; @@ -5344,7 +5529,13 @@ PP(pp_ggrent) grent = (const struct group *)getgrnam(name); } else if (which == OP_GGRGID) { +#if Gid_t_sign == 1 + const Gid_t gid = POPu; +#elif Gid_t_sign == -1 const Gid_t gid = POPi; +#else +# error "Unexpected Gid_t_sign" +#endif grent = (const struct group *)getgrgid(gid); } else @@ -5355,17 +5546,13 @@ PP(pp_ggrent) #endif EXTEND(SP, 4); - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { SV * const sv = sv_newmortal(); 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); } @@ -5381,11 +5568,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 @@ -5409,7 +5592,7 @@ PP(pp_ggrent) PP(pp_getlogin) { #ifdef HAS_GETLOGIN - dVAR; dSP; dTARGET; + dSP; dTARGET; char *tmps; EXTEND(SP, 1); if (!(tmps = PerlProc_getlogin())) @@ -5427,7 +5610,7 @@ PP(pp_getlogin) PP(pp_syscall) { #ifdef HAS_SYSCALL - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; I32 items = SP - MARK; unsigned long a[20]; I32 i = 0; @@ -5618,11 +5801,5 @@ lockf_emulate_flock(int fd, int operation) #endif /* LOCKF_EMULATE_FLOCK */ /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */