# include <shadow.h>
#endif
-#ifdef I_SYS_WAIT
-# include <sys/wait.h>
-#endif
-
#ifdef I_SYS_RESOURCE
# include <sys/resource.h>
#endif
if (setresuid(euid, ruid, (Uid_t)-1))
#endif
#endif
+ /* diag_listed_as: entering effective %s failed */
Perl_croak(aTHX_ "entering effective uid failed");
#endif
if (setresgid(egid, rgid, (Gid_t)-1))
#endif
#endif
+ /* diag_listed_as: entering effective %s failed */
Perl_croak(aTHX_ "entering effective gid failed");
#endif
if (setresuid(ruid, euid, (Uid_t)-1))
#endif
#endif
+ /* diag_listed_as: leaving effective %s failed */
Perl_croak(aTHX_ "leaving effective uid failed");
#ifdef HAS_SETREGID
if (setresgid(rgid, egid, (Gid_t)-1))
#endif
#endif
+ /* diag_listed_as: leaving effective %s failed */
Perl_croak(aTHX_ "leaving effective gid failed");
return res;
{
dVAR;
OP *result;
- tryAMAGICunTARGET(iter, -1);
+ 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(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
+
+ 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
+ * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
+ * */
+ return NORMAL;
+ }
+ if (PL_globhook) {
+ 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
ENTER_with_name("glob");
#ifndef VMS
- if (PL_tainting) {
+ if (TAINTING_get) {
/*
* The external globbing program may use things we can't control,
* so for security reasons we must assume the worst.
#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);
{
dVAR; dSP; dMARK;
SV *exsv;
- const char *pv;
STRLEN len;
if (SP - MARK > 1) {
dTARGET;
}
else {
exsv = TOPs;
+ if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
}
- 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)) {
- exsv = ERRSV;
- }
- else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
- exsv = sv_mortalcopy(ERRSV);
- sv_catpvs(exsv, "\t...caught");
- }
else {
+ SV * const errsv = ERRSV;
+ SvGETMAGIC(errsv);
+ if (SvROK(errsv)) {
+ if (SvGMAGICAL(errsv)) {
+ exsv = sv_newmortal();
+ sv_setsv_nomg(exsv, errsv);
+ }
+ else exsv = errsv;
+ }
+ else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
+ exsv = sv_newmortal();
+ sv_setsv_nomg(exsv, errsv);
+ sv_catpvs(exsv, "\t...caught");
+ }
+ 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)) {
- 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 (SvPOK(errsv) && SvCUR(errsv)) {
+ exsv = sv_mortalcopy(errsv);
+ sv_catpvs(exsv, "\t...propagated");
+ }
+ else {
+ exsv = newSVpvs_flags("Died", SVs_TEMP);
+ }
}
return die_sv(exsv);
}
/* I/O. */
+OP *
+Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
+ const MAGIC *const mg, const U32 flags, U32 argc, ...)
+{
+ SV **orig_sp = sp;
+ I32 ret_args;
+
+ PERL_ARGS_ASSERT_TIED_METHOD;
+
+ /* Ensure that our flag bits do not overlap. */
+ assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
+ assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
+ assert((TIED_METHOD_SAY & G_WANT) == 0);
+
+ PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
+ PUSHSTACKi(PERLSI_MAGIC);
+ EXTEND(SP, argc+1); /* object + args */
+ PUSHMARK(sp);
+ PUSHs(SvTIED_obj(sv, mg));
+ if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
+ Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
+ sp += argc;
+ }
+ else if (argc) {
+ const U32 mortalize_not_needed
+ = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
+ va_list args;
+ va_start(args, argc);
+ do {
+ SV *const arg = va_arg(args, SV *);
+ if(mortalize_not_needed)
+ PUSHs(arg);
+ else
+ mPUSHs(arg);
+ } while (--argc);
+ va_end(args);
+ }
+
+ PUTBACK;
+ ENTER_with_name("call_tied_method");
+ if (flags & TIED_METHOD_SAY) {
+ /* local $\ = "\n" */
+ SAVEGENERICSV(PL_ors_sv);
+ PL_ors_sv = newSVpvs("\n");
+ }
+ ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
+ SPAGAIN;
+ orig_sp = sp;
+ POPSTACK;
+ SPAGAIN;
+ if (ret_args) { /* copy results back to original stack */
+ EXTEND(sp, ret_args);
+ Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
+ sp += ret_args;
+ PUTBACK;
+ }
+ LEAVE_with_name("call_tied_method");
+ return NORMAL;
+}
+
+#define tied_method0(a,b,c,d) \
+ Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
+#define tied_method1(a,b,c,d,e) \
+ Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
+#define tied_method2(a,b,c,d,e,f) \
+ Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
+
PP(pp_open)
{
dVAR; dSP;
DIE(aTHX_ PL_no_usym, "filehandle");
if ((io = GvIOp(gv))) {
- MAGIC *mg;
+ const MAGIC *mg;
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
if (IoDIRP(io))
Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
- "Opening dirhandle %s also as a file",
- GvENAME(gv));
+ "Opening dirhandle %"HEKf" also as a file",
+ HEKfARG(GvENAME_HEK(gv)));
mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
/* Method's args are same as ours ... */
/* ... except handle is replaced by the object */
- *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg);
- PUSHMARK(MARK);
- PUTBACK;
- ENTER_with_name("call_OPEN");
- call_method("OPEN", G_SCALAR);
- LEAVE_with_name("call_OPEN");
- return NORMAL;
+ return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
+ G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
+ sp - mark);
}
}
RETURN;
}
-/* These are private to this function, which is private to this file.
- Use 0x04 rather than the next available bit, to help the compiler if the
- architecture can generate more efficient instructions. */
-#define MORTALIZE_NOT_NEEDED 0x04
-#define TIED_HANDLE_ARGC_SHIFT 3
-
-static OP *
-S_tied_handle_method(pTHX_ const char *const methname, SV **sp,
- IO *const io, MAGIC *const mg, const U32 flags, ...)
-{
- U32 argc = flags >> TIED_HANDLE_ARGC_SHIFT;
-
- PERL_ARGS_ASSERT_TIED_HANDLE_METHOD;
-
- /* Ensure that our flag bits do not overlap. */
- assert((MORTALIZE_NOT_NEEDED & G_WANT) == 0);
- assert((G_WANT >> TIED_HANDLE_ARGC_SHIFT) == 0);
-
- PUSHMARK(sp);
- PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
- if (argc) {
- const U32 mortalize_not_needed = flags & MORTALIZE_NOT_NEEDED;
- va_list args;
- va_start(args, flags);
- do {
- SV *const arg = va_arg(args, SV *);
- if(mortalize_not_needed)
- PUSHs(arg);
- else
- mPUSHs(arg);
- } while (--argc);
- va_end(args);
- }
-
- PUTBACK;
- ENTER_with_name("call_tied_handle_method");
- call_method(methname, flags & G_WANT);
- LEAVE_with_name("call_tied_handle_method");
- return NORMAL;
-}
-
-#define tied_handle_method(a,b,c,d) \
- S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR)
-#define tied_handle_method1(a,b,c,d,e) \
- S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (1 << TIED_HANDLE_ARGC_SHIFT),e)
-#define tied_handle_method2(a,b,c,d,e,f) \
- S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (2 << TIED_HANDLE_ARGC_SHIFT), e,f)
-
PP(pp_close)
{
dVAR; dSP;
- GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs);
+ GV * const gv =
+ MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
if (MAXARG == 0)
EXTEND(SP, 1);
if (gv) {
IO * const io = GvIO(gv);
if (io) {
- MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
+ const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- return tied_handle_method("CLOSE", SP, io, mg);
+ return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
}
}
}
#ifdef HAS_PIPE
dVAR;
dSP;
- register IO *rstio;
- register IO *wstio;
+ IO *rstio;
+ IO *wstio;
int fd[2];
GV * const wgv = MUTABLE_GV(POPs);
GV *gv;
IO *io;
PerlIO *fp;
- MAGIC *mg;
+ const MAGIC *mg;
if (MAXARG < 1)
RETPUSHUNDEF;
gv = MUTABLE_GV(POPs);
+ io = GvIO(gv);
- if (gv && (io = GvIO(gv))
+ if (io
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
{
- return tied_handle_method("FILENO", SP, io, mg);
+ return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
}
- if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
+ if (!io || !(fp = IoIFP(io))) {
/* Can't do this because people seem to do things like
defined(fileno($foo)) to check whether $foo is a valid fh.
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
}
gv = MUTABLE_GV(POPs);
+ io = GvIO(gv);
- if (gv && (io = GvIO(gv))) {
- MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
+ if (io) {
+ const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
/* This takes advantage of the implementation of the varargs
function, which I don't think that the optimiser will be able to
figure out. Although, as it's a static function, in theory it
could. */
- return S_tied_handle_method(aTHX_ "BINMODE", SP, io, mg,
- G_SCALAR|MORTALIZE_NOT_NEEDED
- | (discp
- ? (1 << TIED_HANDLE_ARGC_SHIFT) : 0),
- discp);
+ return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
+ G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
+ discp ? 1 : 0, discp);
}
}
- if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
+ if (!io || !(fp = IoIFP(io))) {
report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
switch(SvTYPE(varsv)) {
case SVt_PVHV:
+ {
+ HE *entry;
methname = "TIEHASH";
+ if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
+ HvLAZYDEL_off(varsv);
+ hv_free_ent((HV *)varsv, entry);
+ }
HvEITER_set(MUTABLE_HV(varsv), 0);
break;
+ }
case SVt_PVAV:
methname = "TIEARRAY";
+ if (!AvREAL(varsv)) {
+ if (!AvREIFY(varsv))
+ Perl_croak(aTHX_ "Cannot tie unreifiable array");
+ av_clear((AV *)varsv);
+ AvREIFY_off(varsv);
+ AvREAL_on(varsv);
+ }
break;
case SVt_PVGV:
case SVt_PVLV:
- 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
varsv = MUTABLE_SV(GvIOp(varsv));
break;
}
+ if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
+ vivify_defelem(varsv);
+ varsv = LvTARG(varsv);
+ }
/* FALL THROUGH */
default:
methname = "TIESCALAR";
* 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));
}
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 (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));
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 (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
+ !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
if ((mg = SvTIED_mg(sv, how))) {
- SV *osv = SvTIED_obj(sv, mg);
- if (osv == mg->mg_obj)
- osv = sv_mortalcopy(osv);
- PUSHs(osv);
+ PUSHs(SvTIED_obj(sv, mg));
RETURN;
}
RETPUSHUNDEF;
if (SvIV(right))
mPUSHu(O_RDWR|O_CREAT);
else
+ {
mPUSHu(O_RDWR);
+ if (!SvOK(right)) right = &PL_sv_no;
+ }
PUSHs(right);
PUTBACK;
call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
{
#ifdef HAS_SELECT
dVAR; dSP; dTARGET;
- register I32 i;
- register I32 j;
- register char *s;
- register SV *sv;
+ I32 i;
+ I32 j;
+ char *s;
+ SV *sv;
NV value;
I32 maxlen = 0;
I32 nfound;
SP -= 4;
for (i = 1; i <= 3; i++) {
SV * const sv = SP[i];
+ SvGETMAGIC(sv);
if (!SvOK(sv))
continue;
if (SvREADONLY(sv)) {
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
- if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
- Perl_croak_no_modify(aTHX);
+ if (!(SvPOK(sv) && SvCUR(sv) == 0))
+ Perl_croak_no_modify();
}
+ else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
if (!SvPOK(sv)) {
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
- SvPV_force_nolen(sv); /* force string conversion */
+ if (!SvPOKp(sv))
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Non-string passed as bitmask");
+ SvPV_force_nomg_nolen(sv); /* force string conversion */
}
j = SvCUR(sv);
if (maxlen < j)
Perl_setdefout(pTHX_ GV *gv)
{
dVAR;
- SvREFCNT_inc_simple_void(gv);
+ PERL_ARGS_ASSERT_SETDEFOUT;
+ SvREFCNT_inc_simple_void_NN(gv);
SvREFCNT_dec(PL_defoutgv);
PL_defoutgv = gv;
}
HV *hv;
GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
GV * egv = GvEGVx(PL_defoutgv);
+ GV * const *gvp;
if (!egv)
egv = PL_defoutgv;
hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
- if (! hv)
- XPUSHs(&PL_sv_undef);
- else {
- GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
- if (gvp && *gvp == egv) {
+ gvp = hv && HvENAME(hv)
+ ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
+ : NULL;
+ if (gvp && *gvp == egv) {
gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
XPUSHTARG;
- }
- else {
+ }
+ else {
mXPUSHs(newRV(MUTABLE_SV(egv)));
- }
}
if (newdefout) {
PP(pp_getc)
{
dVAR; dSP; dTARGET;
- IO *io = NULL;
- GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
+ GV * const gv =
+ MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
+ IO *const io = GvIO(gv);
if (MAXARG == 0)
EXTEND(SP, 1);
- if (gv && (io = GvIO(gv))) {
- MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
+ if (io) {
+ const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
const U32 gimme = GIMME_V;
- S_tied_handle_method(aTHX_ "GETC", SP, io, mg, gimme);
+ Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
if (gimme == G_SCALAR) {
SPAGAIN;
SvSetMagicSV_nosteal(TARG, TOPs);
S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
{
dVAR;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
PERL_ARGS_ASSERT_DOFORM;
PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
PUSHFORMAT(cx, retop);
+ if (CvDEPTH(cv) >= 2) {
+ PERL_STACK_OVERFLOW_CHECK();
+ pad_push(CvPADLIST(cv), CvDEPTH(cv));
+ }
SAVECOMPPAD();
- PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
+ PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
setdefout(gv); /* locally select filehandle so $% et al work */
return CvSTART(cv);
{
dVAR;
dSP;
- register GV *gv;
- register IO *io;
+ GV *gv;
+ IO *io;
GV *fgv;
CV *cv = NULL;
SV *tmpsv = NULL;
else
fgv = gv;
- if (!fgv)
- goto not_a_format_reference;
+ assert(fgv);
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);
-
- not_a_format_reference:
- DIE(aTHX_ "Not a format reference");
+ DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
}
IoFLAGS(io) &= ~IOf_DIDTOP;
- return doform(cv,gv,PL_op->op_next);
+ RETURNOP(doform(cv,gv,PL_op->op_next));
}
PP(pp_leavewrite)
{
dVAR; dSP;
GV * const gv = cxstack[cxstack_ix].blk_format.gv;
- register IO * const io = GvIOp(gv);
+ IO * const io = GvIOp(gv);
PerlIO *ofp;
PerlIO *fp;
SV **newsp;
I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
OP *retop;
if (!io || !(ofp = IoOFP(io)))
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))
}
}
if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
- do_print(PL_formfeed, ofp);
+ do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
IoLINES_LEFT(io) = IoPAGE_LEN(io);
IoPAGE(io)++;
PL_formtarget = PL_toptarget;
IoFLAGS(io) |= IOf_DIDTOP;
fgv = IoTOP_GV(io);
- if (!fgv)
- DIE(aTHX_ "bad top format reference");
+ assert(fgv); /* IoTOP_GV(io) should have been set above */
cv = GvFORM(fgv);
if (!cv) {
SV * const sv = sv_newmortal();
- 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);
- else
- DIE(aTHX_ "Undefined top format called");
+ DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
}
return doform(cv, gv, PL_op);
}
POPBLOCK(cx,PL_curpm);
POPFORMAT(cx);
retop = cx->blk_sub.retop;
+ SP = newsp; /* ignore retval of formline */
LEAVE;
- fp = IoOFP(io);
- if (!fp) {
- if (IoIFP(io))
+ if (!io || !(fp = IoOFP(io))) {
+ if (io && IoIFP(io))
report_wrongway_fh(gv, '<');
else
report_evil_fh(gv);
PUSHs(&PL_sv_yes);
}
}
- /* bad_ofp: */
PL_formtarget = PL_bodytarget;
- PUTBACK;
- PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(gimme);
- return retop;
+ RETURNOP(retop);
}
PP(pp_prtf)
{
dVAR; dSP; dMARK; dORIGMARK;
- IO *io;
PerlIO *fp;
- SV *sv;
GV * const gv
= (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
+ IO *const io = GvIO(gv);
- if (gv && (io = GvIO(gv))) {
- MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
+ /* Treat empty list as "" */
+ if (MARK == SP) XPUSHs(&PL_sv_no);
+
+ if (io) {
+ const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
if (MARK == ORIGMARK) {
MEXTEND(SP, 1);
Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
++SP;
}
- PUSHMARK(MARK - 1);
- *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
- PUTBACK;
- ENTER;
- call_method("PRINTF", G_SCALAR);
- LEAVE;
- return NORMAL;
+ return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
+ mg,
+ G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
+ sp - mark);
}
}
- sv = newSV(0);
- if (!(io = GvIO(gv))) {
+ if (!io) {
report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
goto just_say_no;
goto just_say_no;
}
else {
- if (SvTAINTED(MARK[1]))
- TAINT_PROPER("printf");
+ SV *sv = sv_newmortal();
do_sprintf(sv, SP - MARK, MARK + 1);
if (!do_print(sv, fp))
goto just_say_no;
if (PerlIO_flush(fp) == EOF)
goto just_say_no;
}
- SvREFCNT_dec(sv);
SP = ORIGMARK;
PUSHs(&PL_sv_yes);
RETURN;
just_say_no:
- SvREFCNT_dec(sv);
SP = ORIGMARK;
PUSHs(&PL_sv_undef);
RETURN;
{
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);
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;
if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
&& gv && (io = GvIO(gv)) )
{
- const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
+ const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- PUSHMARK(MARK-1);
- *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
- ENTER;
- call_method("READ", G_SCALAR);
- LEAVE;
- return NORMAL;
+ return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
+ G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
+ sp - mark);
}
}
if (! SvOK(bufsv))
sv_setpvs(bufsv, "");
length = SvIVx(*++MARK);
+ if (length < 0)
+ DIE(aTHX_ "Negative length");
SETERRNO(0,0);
if (MARK < SP)
offset = SvIVx(*++MARK);
buffer = SvPV_force(bufsv, blen);
buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
}
- if (length < 0)
- DIE(aTHX_ "Negative length");
- wanted = length;
+ if (DO_UTF8(bufsv)) {
+ blen = sv_len_utf8_nomg(bufsv);
+ }
charstart = TRUE;
charskip = 0;
skip = 0;
+ wanted = length;
#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__)
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
bufsize = sizeof (struct sockaddr_in);
#else
bufsize = sizeof namebuf;
/* 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);
PUSHs(TARG);
RETURN;
}
-#else
- if (PL_op->op_type == OP_RECV)
- DIE(aTHX_ PL_no_sock_func, "recv");
#endif
- if (DO_UTF8(bufsv)) {
- /* offset adjust in characters not bytes */
- blen = sv_len_utf8(bufsv);
- }
if (offset < 0) {
- if (-offset > (int)blen)
+ if (-offset > (SSize_t)blen)
DIE(aTHX_ "Offset outside string");
offset += blen;
}
if (DO_UTF8(bufsv)) {
/* convert offset-as-chars to offset-as-bytes */
- if (offset >= (int)blen)
+ if (offset >= (SSize_t)blen)
offset += SvCUR(bufsv) - blen;
else
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) {
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);
RETPUSHUNDEF;
}
-PP(pp_send)
+PP(pp_syswrite)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- IO *io;
SV *bufsv;
const char *buffer;
SSize_t retval;
const int op_type = PL_op->op_type;
bool doing_utf8;
U8 *tmpbuf = NULL;
-
GV *const gv = MUTABLE_GV(*++MARK);
- if (PL_op->op_type == OP_SYSWRITE
- && gv && (io = GvIO(gv))) {
- MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
+ IO *const io = GvIO(gv);
+
+ if (op_type == OP_SYSWRITE && io) {
+ const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
if (MARK == SP - 1) {
SV *sv = *SP;
PUTBACK;
}
- PUSHMARK(ORIGMARK);
- *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
- ENTER;
- call_method("WRITE", G_SCALAR);
- LEAVE;
- return NORMAL;
+ return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
+ G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
+ sp - mark);
}
}
if (!gv)
bufsv = *++MARK;
SETERRNO(0,0);
- io = GvIO(gv);
if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
retval = -1;
if (io && IoIFP(io))
}
}
- if (op_type == OP_SYSWRITE) {
+#ifdef HAS_SOCKET
+ if (op_type == OP_SEND) {
+ const int flags = SvIVx(*++MARK);
+ if (SP > MARK) {
+ STRLEN mlen;
+ char * const sockbuf = SvPVx(*++MARK, mlen);
+ retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
+ flags, (struct sockaddr *)sockbuf, mlen);
+ }
+ else {
+ retval
+ = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
+ }
+ }
+ else
+#endif
+ {
Size_t length = 0; /* This length is in characters. */
STRLEN blen_chars;
IV offset;
blen_chars = orig_blen_bytes;
} else {
/* The SV really is UTF-8. */
- if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
- /* Don't call sv_len_utf8 again because it will call magic
- or overloading a second time, and we might get back a
- different result. */
- blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
- } else {
- /* It's safe, and it may well be cached. */
- blen_chars = sv_len_utf8(bufsv);
- }
+ /* Don't call sv_len_utf8 on a magical or overloaded
+ scalar, as we might get back a different result. */
+ blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
}
} else {
blen_chars = blen;
buffer, length);
}
}
-#ifdef HAS_SOCKET
- else {
- const int flags = SvIVx(*++MARK);
- if (SP > MARK) {
- STRLEN mlen;
- char * const sockbuf = SvPVx(*++MARK, mlen);
- retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
- flags, (struct sockaddr *)sockbuf, mlen);
- }
- else {
- retval
- = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
- }
- }
-#else
- else
- DIE(aTHX_ PL_no_sock_func, "send");
-#endif
if (retval < 0)
goto say_undef;
dVAR; dSP;
GV *gv;
IO *io;
- MAGIC *mg;
+ const MAGIC *mg;
/*
* in Perl 5.12 and later, the additional parameter is a bitmask:
* 0 = eof
RETPUSHNO;
if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
- return tied_handle_method1("EOF", SP, io, mg, newSVuv(which));
+ return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
}
if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
GV *gv;
IO *io;
- if (MAXARG != 0)
+ if (MAXARG != 0 && (TOPs || POPs))
PL_last_in_gv = MUTABLE_GV(POPs);
else
EXTEND(SP, 1);
gv = PL_last_in_gv;
- if (gv && (io = GvIO(gv))) {
- MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
+ io = GvIO(gv);
+ if (io) {
+ const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- return tied_handle_method("TELL", SP, io, mg);
+ return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
}
}
else if (!gv) {
#endif
GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
- IO *io;
+ IO *const io = GvIO(gv);
- if (gv && (io = GvIO(gv))) {
- MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
+ if (io) {
+ const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
#if LSEEKSIZE > IVSIZE
SV *const offset_sv = newSVnv((NV) offset);
SV *const offset_sv = newSViv(offset);
#endif
- return tied_handle_method2("SEEK", SP, io, mg, offset_sv,
- newSViv(whence));
+ return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
+ newSViv(whence));
}
}
/* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
SETERRNO(0,0);
{
+ SV * const sv = POPs;
int result = 1;
GV *tmpgv;
IO *io;
- if (PL_op->op_flags & OPf_SPECIAL) {
- tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
-
- do_ftruncate_gv:
- if (!GvIO(tmpgv))
+ if (PL_op->op_flags & OPf_SPECIAL
+ ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
+ : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
+ io = GvIO(tmpgv);
+ if (!io)
result = 0;
else {
PerlIO *fp;
- io = GvIOp(tmpgv);
do_ftruncate_io:
TAINT_PROPER("truncate");
if (!(fp = IoIFP(io))) {
}
}
}
- 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)
#ifdef FLOCK
dVAR; dSP; dTARGET;
I32 value;
- IO *io = NULL;
- PerlIO *fp;
const int argtype = POPi;
- GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
+ GV * const gv = MUTABLE_GV(POPs);
+ IO *const io = GvIO(gv);
+ PerlIO *const fp = io ? IoIFP(io) : NULL;
- if (gv && (io = GvIO(gv)))
- fp = IoIFP(io);
- else {
- fp = NULL;
- io = NULL;
- }
/* XXX Looks to me like io is always NULL at this point */
if (fp) {
(void)PerlIO_flush(fp);
/* Sockets. */
+#ifdef HAS_SOCKET
+
PP(pp_socket)
{
-#ifdef HAS_SOCKET
dVAR; dSP;
const int protocol = POPi;
const int type = POPi;
const int domain = POPi;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = gv ? GvIOn(gv) : NULL;
+ IO * const io = gv ? GvIOn(gv) : NULL;
int fd;
- if (!gv || !io) {
+ if (!io) {
report_evil_fh(gv);
if (io && IoIFP(io))
do_close(gv, FALSE);
fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
#endif
-#ifdef EPOC
- setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
-#endif
-
RETPUSHYES;
-#else
- DIE(aTHX_ PL_no_sock_func, "socket");
-#endif
}
+#endif
PP(pp_sockpair)
{
const int domain = POPi;
GV * const gv2 = MUTABLE_GV(POPs);
GV * const gv1 = MUTABLE_GV(POPs);
- register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
- register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
+ IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
+ IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
int fd[2];
- if (!gv1 || !gv2 || !io1 || !io2) {
- if (!gv1 || !io1)
- report_evil_fh(gv1);
- if (!gv2 || !io2)
- report_evil_fh(gv2);
- }
+ if (!io1)
+ report_evil_fh(gv1);
+ if (!io2)
+ report_evil_fh(gv2);
if (io1 && IoIFP(io1))
do_close(gv1, FALSE);
#endif
}
+#ifdef HAS_SOCKET
+
PP(pp_bind)
{
-#ifdef HAS_SOCKET
dVAR; dSP;
SV * const addrsv = POPs;
/* OK, so on what platform does bind modify addr? */
const char *addr;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
- STRLEN len;
-
- if (!io || !IoIFP(io))
- goto nuts;
-
- addr = SvPV_const(addrsv, len);
- TAINT_PROPER("bind");
- if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
- RETPUSHYES;
- else
- RETPUSHUNDEF;
-
-nuts:
- report_evil_fh(gv);
- SETERRNO(EBADF,SS_IVCHAN);
- RETPUSHUNDEF;
-#else
- DIE(aTHX_ PL_no_sock_func, "bind");
-#endif
-}
-
-PP(pp_connect)
-{
-#ifdef HAS_SOCKET
- dVAR; dSP;
- SV * const addrsv = POPs;
- GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
- const char *addr;
+ IO * const io = GvIOn(gv);
STRLEN len;
+ const int op_type = PL_op->op_type;
if (!io || !IoIFP(io))
goto nuts;
addr = SvPV_const(addrsv, len);
- TAINT_PROPER("connect");
- if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
+ TAINT_PROPER(PL_op_desc[op_type]);
+ if ((op_type == OP_BIND
+ ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
+ : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
+ >= 0)
RETPUSHYES;
else
RETPUSHUNDEF;
report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
-#else
- DIE(aTHX_ PL_no_sock_func, "connect");
-#endif
}
PP(pp_listen)
{
-#ifdef HAS_SOCKET
dVAR; dSP;
const int backlog = POPi;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = gv ? GvIOn(gv) : NULL;
+ IO * const io = gv ? GvIOn(gv) : NULL;
- if (!gv || !io || !IoIFP(io))
+ if (!io || !IoIFP(io))
goto nuts;
if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
-#else
- DIE(aTHX_ PL_no_sock_func, "listen");
-#endif
}
PP(pp_accept)
{
-#ifdef HAS_SOCKET
dVAR; dSP; dTARGET;
- register IO *nstio;
- register IO *gstio;
+ IO *nstio;
+ IO *gstio;
char namebuf[MAXPATHLEN];
-#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
Sock_size_t len = sizeof (struct sockaddr_in);
#else
Sock_size_t len = sizeof namebuf;
fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
#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
badexit:
RETPUSHUNDEF;
-#else
- DIE(aTHX_ PL_no_sock_func, "accept");
-#endif
}
PP(pp_shutdown)
{
-#ifdef HAS_SOCKET
dVAR; dSP; dTARGET;
const int how = POPi;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
if (!io || !IoIFP(io))
goto nuts;
report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
-#else
- DIE(aTHX_ PL_no_sock_func, "shutdown");
-#endif
}
PP(pp_ssockopt)
{
-#ifdef HAS_SOCKET
dVAR; dSP;
const int optype = PL_op->op_type;
SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
const unsigned int optname = (unsigned int) POPi;
const unsigned int lvl = (unsigned int) POPi;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
int fd;
Sock_size_t len;
nuts2:
RETPUSHUNDEF;
-#else
- DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
-#endif
}
PP(pp_getpeername)
{
-#ifdef HAS_SOCKET
dVAR; dSP;
const int optype = PL_op->op_type;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
Sock_size_t len;
SV *sv;
int fd;
SETERRNO(EBADF,SS_IVCHAN);
nuts2:
RETPUSHUNDEF;
+}
-#else
- DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
-}
/* Stat calls. */
dVAR;
dSP;
GV *gv = NULL;
- IO *io;
+ IO *io = NULL;
I32 gimme;
I32 max = 13;
+ SV* sv;
- if (PL_op->op_flags & OPf_REF) {
- gv = cGVOP_gv;
+ if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
+ : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
if (PL_op->op_type == OP_LSTAT) {
if (gv != PL_defgv) {
do_fstat_warning_check:
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
+ "lstat() on filehandle%s%"SVf,
+ gv ? " " : "",
+ SVfARG(gv
+ ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
+ : &PL_sv_no));
} else if (PL_laststype != OP_LSTAT)
+ /* diag_listed_as: The stat preceding %s wasn't an lstat */
Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
}
- do_fstat:
if (gv != PL_defgv) {
+ bool havefp;
+ do_fstat_have_io:
+ havefp = FALSE;
PL_laststype = OP_STAT;
- PL_statgv = gv;
+ PL_statgv = gv ? gv : (GV *)io;
sv_setpvs(PL_statname, "");
if(gv) {
io = GvIO(gv);
- do_fstat_have_io:
- if (io) {
+ }
+ if (io) {
if (IoIFP(io)) {
PL_laststatval =
PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
+ havefp = TRUE;
} else if (IoDIRP(io)) {
PL_laststatval =
PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
+ havefp = TRUE;
} else {
PL_laststatval = -1;
}
- }
}
+ else PL_laststatval = -1;
+ if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
}
if (PL_laststatval < 0) {
- report_evil_fh(gv);
max = 0;
}
}
else {
- SV* const sv = POPs;
- if (isGV_with_GP(sv)) {
- gv = MUTABLE_GV(sv);
- goto do_fstat;
- } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
- gv = MUTABLE_GV(SvRV(sv));
- if (PL_op->op_type == OP_LSTAT)
- goto do_fstat_warning_check;
- goto do_fstat;
- } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
+ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
io = MUTABLE_IO(SvRV(sv));
if (PL_op->op_type == OP_LSTAT)
goto do_fstat_warning_check;
goto do_fstat_have_io;
}
- sv_setpv(PL_statname, SvPV_nolen_const(sv));
+ SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
+ 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)
EXTEND(SP, max);
EXTEND_MORTAL(max);
mPUSHi(PL_statcache.st_dev);
- mPUSHi(PL_statcache.st_ino);
- mPUSHu(PL_statcache.st_mode);
- mPUSHu(PL_statcache.st_nlink);
-#if Uid_t_size > IVSIZE
- mPUSHn(PL_statcache.st_uid);
+#if ST_INO_SIZE > IVSIZE
+ mPUSHn(PL_statcache.st_ino);
#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);
+# if ST_INO_SIGN <= 0
+ mPUSHi(PL_statcache.st_ino);
# else
- mPUSHu(PL_statcache.st_gid);
+ mPUSHu(PL_statcache.st_ino);
# endif
#endif
+ mPUSHu(PL_statcache.st_mode);
+ mPUSHu(PL_statcache.st_nlink);
+
+ sv_setuid(PUSHmortal, PL_statcache.st_uid);
+ sv_setgid(PUSHmortal, PL_statcache.st_gid);
+
#ifdef USE_STAT_RDEV
mPUSHi(PL_statcache.st_rdev);
#else
RETURN;
}
+/* All filetest ops avoid manipulating the perl stack pointer in their main
+ bodies (since commit d2c4d2d1e22d3125), and return using either
+ S_ft_return_false() or S_ft_return_true(). These two helper functions are
+ the only two which manipulate the perl stack. To ensure that no stack
+ manipulation macros are used, the filetest ops avoid defining a local copy
+ of the stack pointer with dSP. */
+
+/* If the next filetest is stacked up with this one
+ (PL_op->op_private & OPpFT_STACKING), we leave
+ the original argument on the stack for success,
+ and skip the stacked operators on failure.
+ The next few macros/functions take care of this.
+*/
+
+static OP *
+S_ft_return_false(pTHX_ SV *ret) {
+ OP *next = NORMAL;
+ dSP;
+
+ if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
+ else SETs(ret);
+ PUTBACK;
+
+ if (PL_op->op_private & OPpFT_STACKING) {
+ while (OP_IS_FILETEST(next->op_type)
+ && next->op_private & OPpFT_STACKED)
+ next = next->op_next;
+ }
+ return next;
+}
+
+PERL_STATIC_INLINE OP *
+S_ft_return_true(pTHX_ SV *ret) {
+ dSP;
+ if (PL_op->op_flags & OPf_REF)
+ XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
+ else if (!(PL_op->op_private & OPpFT_STACKING))
+ SETs(ret);
+ PUTBACK;
+ return NORMAL;
+}
+
+#define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
+#define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
+#define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
+
#define tryAMAGICftest_MG(chr) STMT_START { \
- if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
- && S_try_amagic_ftest(aTHX_ chr)) \
- return NORMAL; \
+ if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
+ && PL_op->op_flags & OPf_KIDS) { \
+ OP *next = S_try_amagic_ftest(aTHX_ chr); \
+ if (next) return next; \
+ } \
} STMT_END
-STATIC bool
+STATIC OP *
S_try_amagic_ftest(pTHX_ char chr) {
dVAR;
- dSP;
- SV* const arg = TOPs;
+ SV *const arg = *PL_stack_sp;
assert(chr != '?');
- SvGETMAGIC(arg);
+ if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
- if ((PL_op->op_flags & OPf_KIDS)
- && SvAMAGIC(TOPs))
+ if (SvAMAGIC(arg))
{
const char tmpchr = chr;
- const OP *next;
SV * const tmpsv = amagic_call(arg,
newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
ftest_amg, AMGf_unary);
if (!tmpsv)
- return FALSE;
+ return NULL;
- SPAGAIN;
-
- next = PL_op->op_next;
- if (next->op_type >= OP_FTRREAD &&
- next->op_type <= OP_FTBINARY &&
- next->op_private & OPpFT_STACKED
- ) {
- if (SvTRUE(tmpsv))
- /* leave the object alone */
- return TRUE;
- }
-
- SETs(tmpsv);
- PUTBACK;
- return TRUE;
+ return SvTRUE(tmpsv)
+ ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
}
- return FALSE;
+ return NULL;
}
-/* This macro is used by the stacked filetest operators :
- * if the previous filetest failed, short-circuit and pass its value.
- * Else, discard it from the stack and continue. --rgs
- */
-#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
- if (!SvTRUE(TOPs)) { RETURN; } \
- else { (void)POPs; PUTBACK; } \
- }
-
PP(pp_ftrread)
{
dVAR;
bool effective = FALSE;
char opchar = '?';
- dSP;
switch (PL_op->op_type) {
case OP_FTRREAD: opchar = 'R'; break;
}
tryAMAGICftest_MG(opchar);
- STACKED_FTEST_CHECK;
-
switch (PL_op->op_type) {
case OP_FTRREAD:
#if !(defined(HAS_ACCESS) && defined(R_OK))
if (use_access) {
#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
- const char *name = POPpx;
+ const char *name = SvPV_nolen(*PL_stack_sp);
if (effective) {
# ifdef PERL_EFF_ACCESS
result = PERL_EFF_ACCESS(name, access_mode);
# endif
}
if (result == 0)
- RETPUSHYES;
+ FT_RETURNYES;
if (result < 0)
- RETPUSHUNDEF;
- RETPUSHNO;
+ FT_RETURNUNDEF;
+ FT_RETURNNO;
#endif
}
result = my_stat_flags(0);
- SPAGAIN;
if (result < 0)
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
if (cando(stat_mode, effective, &PL_statcache))
- RETPUSHYES;
- RETPUSHNO;
+ FT_RETURNYES;
+ FT_RETURNNO;
}
PP(pp_ftis)
I32 result;
const int op_type = PL_op->op_type;
char opchar = '?';
- dSP;
switch (op_type) {
case OP_FTIS: opchar = 'e'; break;
}
tryAMAGICftest_MG(opchar);
- STACKED_FTEST_CHECK;
-
result = my_stat_flags(0);
- SPAGAIN;
if (result < 0)
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
if (op_type == OP_FTIS)
- RETPUSHYES;
+ FT_RETURNYES;
{
/* You can't dTARGET inside OP_FTIS, because you'll get
"panic: pad_sv po" - the op is not flagged to have a target. */
switch (op_type) {
case OP_FTSIZE:
#if Off_t_size > IVSIZE
- PUSHn(PL_statcache.st_size);
+ sv_setnv(TARG, (NV)PL_statcache.st_size);
#else
- PUSHi(PL_statcache.st_size);
+ sv_setiv(TARG, (IV)PL_statcache.st_size);
#endif
break;
case OP_FTMTIME:
- PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
+ sv_setnv(TARG,
+ ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
break;
case OP_FTATIME:
- PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
+ sv_setnv(TARG,
+ ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
break;
case OP_FTCTIME:
- PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
+ sv_setnv(TARG,
+ ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
break;
}
+ SvSETMAGIC(TARG);
+ return SvTRUE_nomg(TARG)
+ ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
}
- RETURN;
}
PP(pp_ftrowned)
dVAR;
I32 result;
char opchar = '?';
- dSP;
switch (PL_op->op_type) {
case OP_FTROWNED: opchar = 'O'; break;
}
tryAMAGICftest_MG(opchar);
- STACKED_FTEST_CHECK;
-
/* I believe that all these three are likely to be defined on most every
system these days. */
#ifndef S_ISUID
if(PL_op->op_type == OP_FTSUID) {
- if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
- (void) POPs;
- RETPUSHNO;
+ FT_RETURNNO;
}
#endif
#ifndef S_ISGID
if(PL_op->op_type == OP_FTSGID) {
- if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
- (void) POPs;
- RETPUSHNO;
+ FT_RETURNNO;
}
#endif
#ifndef S_ISVTX
if(PL_op->op_type == OP_FTSVTX) {
- if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
- (void) POPs;
- RETPUSHNO;
+ FT_RETURNNO;
}
#endif
result = my_stat_flags(0);
- SPAGAIN;
if (result < 0)
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
switch (PL_op->op_type) {
case OP_FTROWNED:
- if (PL_statcache.st_uid == PL_uid)
- RETPUSHYES;
+ if (PL_statcache.st_uid == PerlProc_getuid())
+ FT_RETURNYES;
break;
case OP_FTEOWNED:
- if (PL_statcache.st_uid == PL_euid)
- RETPUSHYES;
+ if (PL_statcache.st_uid == PerlProc_geteuid())
+ FT_RETURNYES;
break;
case OP_FTZERO:
if (PL_statcache.st_size == 0)
- RETPUSHYES;
+ FT_RETURNYES;
break;
case OP_FTSOCK:
if (S_ISSOCK(PL_statcache.st_mode))
- RETPUSHYES;
+ FT_RETURNYES;
break;
case OP_FTCHR:
if (S_ISCHR(PL_statcache.st_mode))
- RETPUSHYES;
+ FT_RETURNYES;
break;
case OP_FTBLK:
if (S_ISBLK(PL_statcache.st_mode))
- RETPUSHYES;
+ FT_RETURNYES;
break;
case OP_FTFILE:
if (S_ISREG(PL_statcache.st_mode))
- RETPUSHYES;
+ FT_RETURNYES;
break;
case OP_FTDIR:
if (S_ISDIR(PL_statcache.st_mode))
- RETPUSHYES;
+ FT_RETURNYES;
break;
case OP_FTPIPE:
if (S_ISFIFO(PL_statcache.st_mode))
- RETPUSHYES;
+ FT_RETURNYES;
break;
#ifdef S_ISUID
case OP_FTSUID:
if (PL_statcache.st_mode & S_ISUID)
- RETPUSHYES;
+ FT_RETURNYES;
break;
#endif
#ifdef S_ISGID
case OP_FTSGID:
if (PL_statcache.st_mode & S_ISGID)
- RETPUSHYES;
+ FT_RETURNYES;
break;
#endif
#ifdef S_ISVTX
case OP_FTSVTX:
if (PL_statcache.st_mode & S_ISVTX)
- RETPUSHYES;
+ FT_RETURNYES;
break;
#endif
}
- RETPUSHNO;
+ FT_RETURNNO;
}
PP(pp_ftlink)
{
dVAR;
- dSP;
I32 result;
tryAMAGICftest_MG('l');
result = my_lstat_flags(0);
- SPAGAIN;
if (result < 0)
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
if (S_ISLNK(PL_statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
+ FT_RETURNYES;
+ FT_RETURNNO;
}
PP(pp_fttty)
{
dVAR;
- dSP;
int fd;
GV *gv;
- SV *tmpsv = NULL;
char *name = NULL;
STRLEN namelen;
tryAMAGICftest_MG('t');
- STACKED_FTEST_CHECK;
-
if (PL_op->op_flags & OPf_REF)
gv = cGVOP_gv;
- else if (isGV_with_GP(TOPs))
- gv = MUTABLE_GV(POPs);
- else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
- gv = MUTABLE_GV(SvRV(POPs));
else {
- tmpsv = POPs;
+ SV *tmpsv = *PL_stack_sp;
+ if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
name = SvPV_nomg(tmpsv, namelen);
gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
+ }
}
if (GvIO(gv) && IoIFP(GvIOp(gv)))
fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
- else if (tmpsv && SvOK(tmpsv)) {
- if (isDIGIT(*name))
+ else if (name && isDIGIT(*name))
fd = atoi(name);
- else
- RETPUSHUNDEF;
- }
else
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
if (PerlLIO_isatty(fd))
- RETPUSHYES;
- RETPUSHNO;
+ FT_RETURNYES;
+ FT_RETURNNO;
}
-#if defined(atarist) /* this will work with atariST. Configure will
- make guesses for other systems. */
-# define FILE_base(f) ((f)->_base)
-# define FILE_ptr(f) ((f)->_ptr)
-# define FILE_cnt(f) ((f)->_cnt)
-# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
-#endif
-
PP(pp_fttext)
{
dVAR;
- dSP;
I32 i;
I32 len;
I32 odd = 0;
STDCHAR tbuf[512];
- register STDCHAR *s;
- register IO *io;
- register SV *sv;
+ STDCHAR *s;
+ IO *io;
+ SV *sv = NULL;
GV *gv;
PerlIO *fp;
tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
- STACKED_FTEST_CHECK;
-
if (PL_op->op_flags & OPf_REF)
gv = cGVOP_gv;
- else if (isGV_with_GP(TOPs))
- gv = MUTABLE_GV(POPs);
- else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
- gv = MUTABLE_GV(SvRV(POPs));
- else
- gv = NULL;
+ else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
+ == OPpFT_STACKED)
+ gv = PL_defgv;
+ else {
+ sv = *PL_stack_sp;
+ gv = MAYBE_DEREF_GV_nomg(sv);
+ }
if (gv) {
- EXTEND(SP, 1);
if (gv == PL_defgv) {
if (PL_statgv)
- io = GvIO(PL_statgv);
+ io = SvTYPE(PL_statgv) == SVt_PVIO
+ ? (IO *)PL_statgv
+ : GvIO(PL_statgv);
else {
- sv = PL_statname;
goto really_filename;
}
}
else {
PL_statgv = gv;
- PL_laststatval = -1;
sv_setpvs(PL_statname, "");
io = GvIO(PL_statgv);
}
+ PL_laststatval = -1;
+ PL_laststype = OP_STAT;
if (io && IoIFP(io)) {
if (! PerlIO_has_base(IoIFP(io)))
DIE(aTHX_ "-T and -B not implemented on filehandles");
PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
if (PL_laststatval < 0)
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
if (PL_op->op_type == OP_FTTEXT)
- RETPUSHNO;
+ FT_RETURNNO;
else
- RETPUSHYES;
+ FT_RETURNYES;
}
if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
i = PerlIO_getc(IoIFP(io));
(void)PerlIO_ungetc(IoIFP(io),i);
}
if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
- RETPUSHYES;
+ FT_RETURNYES;
len = PerlIO_get_bufsiz(IoIFP(io));
s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
/* sfio can have large buffers - limit to 512 */
len = 512;
}
else {
- report_evil_fh(cGVOP_gv);
SETERRNO(EBADF,RMS_IFI);
- RETPUSHUNDEF;
+ report_evil_fh(gv);
+ SETERRNO(EBADF,RMS_IFI);
+ FT_RETURNUNDEF;
}
}
else {
- sv = POPs;
+ sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
really_filename:
PL_statgv = NULL;
- PL_laststype = OP_STAT;
- sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
+ if (!gv) {
+ PL_laststatval = -1;
+ PL_laststype = OP_STAT;
+ }
if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
'\n'))
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
}
+ PL_laststype = OP_STAT;
PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
if (PL_laststatval < 0) {
(void)PerlIO_close(fp);
- RETPUSHUNDEF;
+ FT_RETURNUNDEF;
}
PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
len = PerlIO_read(fp, tbuf, sizeof(tbuf));
(void)PerlIO_close(fp);
if (len <= 0) {
if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
- RETPUSHNO; /* special case NFS directories */
- RETPUSHYES; /* null file is anything */
+ FT_RETURNNO; /* special case NFS directories */
+ FT_RETURNYES; /* null file is anything */
}
s = tbuf;
}
}
if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
- RETPUSHNO;
+ FT_RETURNNO;
else
- RETPUSHYES;
+ FT_RETURNYES;
}
/* File calls. */
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) ) {
if (same_dirent(tmps2, tmps)) /* can always rename to same name */
anum = 1;
else {
- if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
+ if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
(void)UNLINK(tmps2);
if (!(anum = link(tmps, tmps2)))
anum = UNLINK(tmps);
; 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)) {
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);
dVAR; dSP;
const char * const dirname = POPpconstx;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ 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 %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)))
SV *sv;
const I32 gimme = GIMME;
GV * const gv = MUTABLE_GV(POPs);
- register const Direntry_t *dp;
- register IO * const io = GvIOn(gv);
+ const Direntry_t *dp;
+ IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io)) {
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;
}
long telldir (DIR *);
# endif
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io)) {
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;
}
dVAR; dSP;
const long along = POPl;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
if (!io || !IoDIRP(io)) {
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);
#if defined(HAS_REWINDDIR) || defined(rewinddir)
dVAR; dSP;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
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));
#if defined(Direntry_t) && defined(HAS_READDIR)
dVAR; dSP;
GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
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
#ifdef HAS_FORK
dVAR; dSP; dTARGET;
Pid_t childpid;
+#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+ sigset_t oldmask, newmask;
+#endif
EXTEND(SP, 1);
PERL_FLUSHALL_FOR_CHILD;
+#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+ sigfillset(&newmask);
+ sigprocmask(SIG_SETMASK, &newmask, &oldmask);
+#endif
childpid = PerlProc_fork();
+ if (childpid == 0) {
+ int sig;
+ PL_sig_pending = 0;
+ if (PL_psig_pend)
+ for (sig = 1; sig < SIG_SIZE; sig++)
+ PL_psig_pend[sig] = 0;
+ }
+#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+ {
+ dSAVE_ERRNO;
+ sigprocmask(SIG_SETMASK, &oldmask, NULL);
+ RESTORE_ERRNO;
+ }
+#endif
if (childpid < 0)
- RETSETUNDEF;
+ RETPUSHUNDEF;
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 PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
#endif
PERL_FLUSHALL_FOR_CHILD;
childpid = PerlProc_fork();
if (childpid == -1)
- RETSETUNDEF;
+ RETPUSHUNDEF;
PUSHi(childpid);
RETURN;
# else
I32 value;
int result;
- if (PL_tainting) {
+ if (TAINTING_get) {
TAINT_ENV();
while (++MARK <= SP) {
(void)SvPV_nolen_const(*MARK); /* stringify for taint check */
- if (PL_tainted)
+ if (TAINT_get)
break;
}
MARK = ORIGMARK;
Pid_t childpid;
int pp[2];
I32 did_pipes = 0;
+#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+ sigset_t newset, oldset;
+#endif
if (PerlProc_pipe(pp) >= 0)
did_pipes = 1;
+#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+ sigemptyset(&newset);
+ sigaddset(&newset, SIGCHLD);
+ sigprocmask(SIG_BLOCK, &newset, &oldset);
+#endif
while ((childpid = PerlProc_fork()) == -1) {
if (errno != EAGAIN) {
value = -1;
PerlLIO_close(pp[0]);
PerlLIO_close(pp[1]);
}
+#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+ sigprocmask(SIG_SETMASK, &oldset, NULL);
+#endif
RETURN;
}
sleep(5);
result = wait4pid(childpid, &status, 0);
} while (result == -1 && errno == EINTR);
#ifndef PERL_MICRO
+#ifdef HAS_SIGPROCMASK
+ sigprocmask(SIG_SETMASK, &oldset, NULL);
+#endif
(void)rsignal_restore(SIGINT, &ihand);
(void)rsignal_restore(SIGQUIT, &qhand);
#endif
PerlLIO_close(pp[0]);
if (n) { /* Error */
if (n != sizeof(int))
- DIE(aTHX_ "panic: kid popen errno read");
+ DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
errno = errkid; /* Propagate errno from kid */
STATUS_NATIVE_CHILD_SET(-1);
}
XPUSHi(STATUS_CURRENT);
RETURN;
}
+#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+ sigprocmask(SIG_SETMASK, &oldset, NULL);
+#endif
if (did_pipes) {
PerlLIO_close(pp[0]);
#if defined(HAS_FCNTL) && defined(F_SETFD)
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
I32 value;
- if (PL_tainting) {
+ if (TAINTING_get) {
TAINT_ENV();
while (++MARK <= SP) {
(void)SvPV_nolen_const(*MARK); /* stringify for taint check */
- if (PL_tainted)
+ if (TAINT_get)
break;
}
MARK = ORIGMARK;
#ifdef VMS
value = (I32)vms_do_aexec(NULL, MARK, SP);
#else
-# ifdef __OPEN_VM
- {
- (void ) do_aspawn(NULL, MARK, SP);
- value = 0;
- }
-# else
value = (I32)do_aexec(NULL, MARK, SP);
-# endif
#endif
else {
#ifdef VMS
value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
#else
-# ifdef __OPEN_VM
- (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
- value = 0;
-# else
value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
-# endif
#endif
}
{
#ifdef HAS_GETPPID
dVAR; dSP; dTARGET;
-# ifdef THREADS_HAVE_PIDS
- if (PL_ppid != 1 && getppid() == 1)
- /* maybe the parent process has died. Refresh ppid cache */
- PL_ppid = 1;
- XPUSHi( PL_ppid );
-# else
XPUSHi( getppid() );
-# endif
RETURN;
#else
DIE(aTHX_ PL_no_func, "getppid");
#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;
NV input = Perl_floor(POPn);
when = (Time64_T)input;
if (when != input) {
+ /* diag_listed_as: gmtime(%f) too large */
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
"%s(%.0" NVff ") too large", opname, input);
}
}
if ( TIME_LOWER_BOUND > when ) {
+ /* diag_listed_as: gmtime(%f) too small */
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
"%s(%.0" NVff ") too small", opname, when);
err = NULL;
}
else if( when > TIME_UPPER_BOUND ) {
+ /* diag_listed_as: gmtime(%f) too small */
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
"%s(%.0" NVff ") too large", opname, when);
err = NULL;
Time_t when;
(void)time(&lasttime);
- if (MAXARG < 1)
+ if (MAXARG < 1 || (!TOPs && !POPs))
PerlProc_pause();
else {
duration = POPi;
PUSHi(value);
RETURN;
#else
- return pp_semget();
+ return Perl_pp_semget(aTHX);
#endif
}
}
RETURN;
#else
- return pp_semget();
+ return Perl_pp_semget(aTHX);
#endif
}
#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
dVAR; dSP;
I32 which = PL_op->op_type;
- register char **elem;
- register SV *sv;
+ char **elem;
+ SV *sv;
#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
struct hostent *gethostbyname(Netdb_name_t);
}
RETURN;
#else
- DIE(aTHX_ PL_no_sock_func, "gethostent");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
}
#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
dVAR; dSP;
I32 which = PL_op->op_type;
- register SV *sv;
+ SV *sv;
#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
struct netent *getnetbyaddr(Netdb_net_t, int);
struct netent *getnetbyname(Netdb_name_t);
RETURN;
#else
- DIE(aTHX_ PL_no_sock_func, "getnetent");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
}
#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
dVAR; dSP;
I32 which = PL_op->op_type;
- register SV *sv;
+ SV *sv;
#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
struct protoent *getprotobyname(Netdb_name_t);
struct protoent *getprotobynumber(int);
RETURN;
#else
- DIE(aTHX_ PL_no_sock_func, "getprotoent");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
}
#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
dVAR; dSP;
I32 which = PL_op->op_type;
- register SV *sv;
+ SV *sv;
#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
struct servent *getservbyport(int, Netdb_name_t);
#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");
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);
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));
}
RETURN;
#else
- DIE(aTHX_ PL_no_sock_func, "getservent");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
}
PP(pp_shostent)
{
-#ifdef HAS_SETHOSTENT
dVAR; dSP;
- PerlSock_sethostent(TOPi);
- RETSETYES;
+ const int stayopen = TOPi;
+ switch(PL_op->op_type) {
+ case OP_SHOSTENT:
+#ifdef HAS_SETHOSTENT
+ PerlSock_sethostent(stayopen);
#else
- DIE(aTHX_ PL_no_sock_func, "sethostent");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
-}
-
-PP(pp_snetent)
-{
+ break;
#ifdef HAS_SETNETENT
- dVAR; dSP;
- (void)PerlSock_setnetent(TOPi);
- RETSETYES;
+ case OP_SNETENT:
+ PerlSock_setnetent(stayopen);
#else
- DIE(aTHX_ PL_no_sock_func, "setnetent");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
-}
-
-PP(pp_sprotoent)
-{
+ break;
+ case OP_SPROTOENT:
#ifdef HAS_SETPROTOENT
- dVAR; dSP;
- (void)PerlSock_setprotoent(TOPi);
- RETSETYES;
+ PerlSock_setprotoent(stayopen);
#else
- DIE(aTHX_ PL_no_sock_func, "setprotoent");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
-}
-
-PP(pp_sservent)
-{
+ break;
+ case OP_SSERVENT:
#ifdef HAS_SETSERVENT
- dVAR; dSP;
- (void)PerlSock_setservent(TOPi);
- RETSETYES;
+ PerlSock_setservent(stayopen);
#else
- DIE(aTHX_ PL_no_sock_func, "setservent");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
+ break;
+ }
+ RETSETYES;
}
PP(pp_ehostent)
{
-#ifdef HAS_ENDHOSTENT
dVAR; dSP;
- PerlSock_endhostent();
- EXTEND(SP,1);
- RETPUSHYES;
+ switch(PL_op->op_type) {
+ case OP_EHOSTENT:
+#ifdef HAS_ENDHOSTENT
+ PerlSock_endhostent();
#else
- DIE(aTHX_ PL_no_sock_func, "endhostent");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
-}
-
-PP(pp_enetent)
-{
+ break;
+ case OP_ENETENT:
#ifdef HAS_ENDNETENT
- dVAR; dSP;
- PerlSock_endnetent();
- EXTEND(SP,1);
- RETPUSHYES;
+ PerlSock_endnetent();
#else
- DIE(aTHX_ PL_no_sock_func, "endnetent");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
-}
-
-PP(pp_eprotoent)
-{
+ break;
+ case OP_EPROTOENT:
#ifdef HAS_ENDPROTOENT
- dVAR; dSP;
- PerlSock_endprotoent();
- EXTEND(SP,1);
- RETPUSHYES;
+ PerlSock_endprotoent();
#else
- DIE(aTHX_ PL_no_sock_func, "endprotoent");
+ DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
-}
-
-PP(pp_eservent)
-{
+ break;
+ case OP_ESERVENT:
#ifdef HAS_ENDSERVENT
- dVAR; dSP;
- PerlSock_endservent();
- EXTEND(SP,1);
- RETPUSHYES;
+ PerlSock_endservent();
+#else
+ DIE(aTHX_ PL_no_sock_func, 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_sock_func, "endservent");
+ DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
#endif
+ break;
+ case OP_SPWENT:
+#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
+ setpwent();
+#else
+ DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
+#endif
+ break;
+ case OP_EPWENT:
+#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
+ endpwent();
+#else
+ DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
+#endif
+ break;
+ }
+ EXTEND(SP,1);
+ RETPUSHYES;
}
PP(pp_gpwent)
#ifdef HAS_PASSWD
dVAR; dSP;
I32 which = PL_op->op_type;
- register SV *sv;
+ SV *sv;
struct passwd *pwent = NULL;
/*
* We currently support only the SysV getsp* shadow password interface.
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);
}
const struct spwd * const spwent = getspnam(pwent->pw_name);
/* Save and restore errno so that
* underprivileged attempts seem
- * to have never made the unsccessful
+ * to have never made the unsuccessful
* attempt to retrieve the shadow password. */
RESTORE_ERRNO;
if (spwent && spwent->sp_pwdp)
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.
#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
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);
}
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
#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
{
#ifdef HAS_SYSCALL
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- register I32 items = SP - MARK;
+ I32 items = SP - MARK;
unsigned long a[20];
- register I32 i = 0;
- I32 retval = -1;
+ I32 i = 0;
+ IV retval = -1;
- if (PL_tainting) {
+ if (TAINTING_get) {
while (++MARK <= SP) {
if (SvTAINTED(*MARK)) {
TAINT;
case 8:
retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
break;
-#ifdef atarist
- case 9:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
- break;
- case 10:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
- break;
- case 11:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10]);
- break;
- case 12:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10],a[11]);
- break;
- case 13:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10],a[11],a[12]);
- break;
- case 14:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10],a[11],a[12],a[13]);
- break;
-#endif /* atarist */
}
SP = ORIGMARK;
PUSHi(retval);
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/