{
dVAR; dSP; dMARK;
SV *exsv;
- const char *pv;
STRLEN len;
if (SP - MARK > 1) {
dTARGET;
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)) {
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;
}
{
dVAR; dSP; dMARK;
SV *exsv;
- const char *pv;
STRLEN len;
#ifdef VMS
VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
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)) {
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_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;
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;
}
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);
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
/* 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
break;
case SVt_PVGV:
case SVt_PVLV:
- if (isGV_with_GP(varsv)) {
- if (SvFAKE(varsv) && !(GvFLAGS(varsv) & GVf_TIEWARNED)) {
- deprecate("tie on a handle without *");
- GvFLAGS(varsv) |= GVf_TIEWARNED;
- }
+ if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
methname = "TIEHANDLE";
how = PERL_MAGIC_tiedscalar;
/* For tied filehandles, we apply tiedscalar magic to the IO
const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- if (isGV_with_GP(sv)) {
- if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
- deprecate("untie on a handle without *");
- GvFLAGS(sv) |= GVf_TIEWARNED;
- }
- if (!(sv = MUTABLE_SV(GvIOp(sv))))
+ if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHYES;
- }
if ((mg = SvTIED_mg(sv, how))) {
SV * const obj = SvRV(SvTIED_obj(sv, mg));
const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- if (isGV_with_GP(sv)) {
- if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
- deprecate("tied on a handle without *");
- GvFLAGS(sv) |= GVf_TIEWARNED;
- }
- if (!(sv = MUTABLE_SV(GvIOp(sv))))
+ if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHUNDEF;
- }
if ((mg = SvTIED_mg(sv, how))) {
SV *osv = SvTIED_obj(sv, mg);
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)
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;
{
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);
GV *gv;
IO *io;
- if (MAXARG != 0)
+ if (MAXARG != 0 && (TOPs || POPs))
PL_last_in_gv = MUTABLE_GV(POPs);
else
EXTEND(SP, 1);
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
&& 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);
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;
if (PL_op->op_flags & OPf_SPECIAL) {
gv = gv_fetchsv(sv, 0, SVt_PVIO);
}
- else if (isGV_with_GP(sv)) {
+ else if (SvGETMAGIC(sv), 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);
+ tmps = SvPV_nomg_const_nolen(sv);
}
}
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);
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
#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);
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
{"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;
Time_t when;
(void)time(&lasttime);
- if (MAXARG < 1)
+ if (MAXARG < 1 || (!TOPs && !POPs))
PerlProc_pause();
else {
duration = POPi;
}
RETURN;
#else
- DIE(aTHX_ PL_no_sock_func, "gethostent");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
}
RETURN;
#else
- DIE(aTHX_ PL_no_sock_func, "getnetent");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
}
RETURN;
#else
- DIE(aTHX_ PL_no_sock_func, "getprotoent");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
}
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)
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;
#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
#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
https://perl5.git.perl.org / perl5.git / blobdiff