X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4be76e1f2b4f53b080616615372a4ebaff876c87..45aff279082494e5b76a5348427b63c8be1066aa:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index a45a8c2..3458177 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 @@ -374,6 +370,11 @@ PP(pp_glob) } /* 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 @@ -511,6 +512,9 @@ 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. */ @@ -518,10 +522,15 @@ Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv, 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) + 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; @@ -544,7 +553,17 @@ Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv, SAVEGENERICSV(PL_ors_sv); PL_ors_sv = newSVpvs("\n"); } - call_method(methname, flags & G_WANT); + 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; } @@ -578,8 +597,8 @@ PP(pp_open) 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) { @@ -613,7 +632,8 @@ PP(pp_open) 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); @@ -730,7 +750,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 @@ -746,7 +766,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 @@ -836,7 +856,7 @@ PP(pp_tie) break; case SVt_PVGV: case SVt_PVLV: - if (isGV_with_GP(varsv)) { + if (isGV_with_GP(varsv) && !SvFAKE(varsv)) { methname = "TIEHANDLE"; how = PERL_MAGIC_tiedscalar; /* For tied filehandles, we apply tiedscalar magic to the IO @@ -869,10 +889,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)); } @@ -913,7 +931,7 @@ PP(pp_untie) const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; - if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) + if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) RETPUSHYES; if ((mg = SvTIED_mg(sv, how))) { @@ -1213,7 +1231,7 @@ PP(pp_select) if (! hv) XPUSHs(&PL_sv_undef); else { - GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE); + GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE); if (gvp && *gvp == egv) { gv_efullname4(TARG, PL_defoutgv, NULL, TRUE); XPUSHTARG; @@ -1235,7 +1253,8 @@ PP(pp_select) PP(pp_getc) { dVAR; dSP; dTARGET; - 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) @@ -1333,12 +1352,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"); @@ -1377,7 +1394,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)) @@ -1424,11 +1442,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"); } @@ -1537,7 +1553,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); @@ -1559,12 +1575,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; @@ -1625,6 +1641,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); @@ -1668,7 +1685,7 @@ PP(pp_sysread) blen = sv_len_utf8(bufsv); } if (offset < 0) { - if (-offset > (int)blen) + if (-offset > (SSize_t)blen) DIE(aTHX_ "Offset outside string"); offset += blen; } @@ -1680,15 +1697,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) { @@ -1722,6 +1739,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); @@ -2072,7 +2090,7 @@ 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); @@ -2168,14 +2186,14 @@ 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 ((tmpgv = PL_op->op_flags & OPf_SPECIAL + ? gv_fetchsv(sv, 0, SVt_PVIO) + : MAYBE_DEREF_GV(sv) )) { io = GvIO(tmpgv); if (!io) result = 0; @@ -2197,24 +2215,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) @@ -2736,19 +2742,22 @@ PP(pp_stat) IO *io; 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 %"SVf, 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) { PL_laststype = OP_STAT; PL_statgv = gv; @@ -2776,23 +2785,14 @@ PP(pp_stat) } } 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) @@ -2816,7 +2816,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 @@ -2869,6 +2877,7 @@ PP(pp_stat) #define tryAMAGICftest_MG(chr) STMT_START { \ if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \ + && PL_op->op_flags & OPf_KIDS \ && S_try_amagic_ftest(aTHX_ chr)) \ return NORMAL; \ } STMT_END @@ -2882,11 +2891,9 @@ S_try_amagic_ftest(pTHX_ char chr) { assert(chr != '?'); 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); @@ -2896,11 +2903,7 @@ S_try_amagic_ftest(pTHX_ char chr) { SPAGAIN; - next = PL_op->op_next; - if (next->op_type >= OP_FTRREAD && - next->op_type <= OP_FTBINARY && - next->op_private & OPpFT_STACKED - ) { + if (PL_op->op_private & OPpFT_STACKING) { if (SvTRUE(tmpsv)) /* leave the object alone */ return TRUE; @@ -3215,6 +3218,7 @@ PP(pp_ftlink) I32 result; tryAMAGICftest_MG('l'); + STACKED_FTEST_CHECK; result = my_lstat_flags(0); SPAGAIN; @@ -3241,11 +3245,7 @@ PP(pp_fttty) 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 { + else if (!(gv = MAYBE_DEREF_GV_nomg(TOPs))) { tmpsv = POPs; name = SvPV_nomg(tmpsv, namelen); gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO); @@ -3294,12 +3294,7 @@ PP(pp_fttext) 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; + else gv = MAYBE_DEREF_GV_nomg(TOPs); if (gv) { EXTEND(SP, 1); @@ -3443,15 +3438,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) ) { @@ -3750,7 +3738,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); @@ -3805,8 +3793,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))) @@ -3841,7 +3829,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; } @@ -3892,7 +3881,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; } @@ -3917,7 +3907,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); @@ -3941,7 +3932,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)); @@ -3964,7 +3956,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 @@ -4296,7 +4289,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); @@ -4318,15 +4312,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 @@ -4455,7 +4446,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; @@ -4555,7 +4546,7 @@ PP(pp_sleep) Time_t when; (void)time(&lasttime); - if (MAXARG < 1) + if (MAXARG < 1 || (!TOPs && !POPs)) PerlProc_pause(); else { duration = POPi;