# include <shadow.h>
#endif
-#ifdef I_SYS_WAIT
-# include <sys/wait.h>
-#endif
-
#ifdef I_SYS_RESOURCE
# include <sys/resource.h>
#endif
{
dVAR;
OP *result;
- tryAMAGICunTARGET(iter, -1);
+ dSP;
+ /* make a copy of the pattern, to ensure that magic is called once
+ * and only once */
+ TOPm1s = sv_2mortal(newSVsv(TOPm1s));
+
+ tryAMAGICunTARGET(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
+
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ /* call Perl-level glob function instead. Stack args are:
+ * MARK, wildcard, csh_glob context index
+ * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
+ * */
+ return NORMAL;
+ }
+ /* stack args are: wildcard, gv(_GEN_n) */
+
+ if (PL_globhook) {
+ SETs(GvSV(TOPs));
+ PL_globhook(aTHX);
+ return NORMAL;
+ }
/* Note that we only ever get here if File::Glob fails to load
* without at the same time croaking, for some reason, or if
{
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)) {
/* I/O. */
+OP *
+Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
+ const MAGIC *const mg, const U32 flags, U32 argc, ...)
+{
+ SV **orig_sp = sp;
+ I32 ret_args;
+
+ PERL_ARGS_ASSERT_TIED_METHOD;
+
+ /* Ensure that our flag bits do not overlap. */
+ assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
+ assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
+ assert((TIED_METHOD_SAY & G_WANT) == 0);
+
+ PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
+ PUSHSTACKi(PERLSI_MAGIC);
+ EXTEND(SP, argc+1); /* object + args */
+ PUSHMARK(sp);
+ PUSHs(SvTIED_obj(sv, mg));
+ if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
+ Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
+ sp += argc;
+ }
+ else if (argc) {
+ const U32 mortalize_not_needed
+ = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
+ va_list args;
+ va_start(args, argc);
+ do {
+ SV *const arg = va_arg(args, SV *);
+ if(mortalize_not_needed)
+ PUSHs(arg);
+ else
+ mPUSHs(arg);
+ } while (--argc);
+ va_end(args);
+ }
+
+ PUTBACK;
+ ENTER_with_name("call_tied_method");
+ if (flags & TIED_METHOD_SAY) {
+ /* local $\ = "\n" */
+ SAVEGENERICSV(PL_ors_sv);
+ PL_ors_sv = newSVpvs("\n");
+ }
+ ret_args = call_method(methname, flags & G_WANT);
+ SPAGAIN;
+ orig_sp = sp;
+ POPSTACK;
+ SPAGAIN;
+ if (ret_args) { /* copy results back to original stack */
+ EXTEND(sp, ret_args);
+ Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
+ sp += ret_args;
+ PUTBACK;
+ }
+ LEAVE_with_name("call_tied_method");
+ return NORMAL;
+}
+
+#define tied_method0(a,b,c,d) \
+ Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
+#define tied_method1(a,b,c,d,e) \
+ Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
+#define tied_method2(a,b,c,d,e,f) \
+ Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
+
PP(pp_open)
{
dVAR; dSP;
DIE(aTHX_ PL_no_usym, "filehandle");
if ((io = GvIOp(gv))) {
- MAGIC *mg;
+ const MAGIC *mg;
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
if (IoDIRP(io))
Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
- "Opening dirhandle %s also as a file",
- GvENAME(gv));
+ "Opening dirhandle %"HEKf" also as a file",
+ HEKfARG(GvENAME_HEK(gv)));
mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
/* Method's args are same as ours ... */
/* ... except handle is replaced by the object */
- *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg);
- PUSHMARK(MARK);
- PUTBACK;
- ENTER_with_name("call_OPEN");
- call_method("OPEN", G_SCALAR);
- LEAVE_with_name("call_OPEN");
- SPAGAIN;
- RETURN;
+ return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
+ G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
+ sp - mark);
}
}
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("CLOSE", SP, MUTABLE_SV(io), mg);
}
}
}
GV *gv;
IO *io;
PerlIO *fp;
- MAGIC *mg;
+ const MAGIC *mg;
if (MAXARG < 1)
RETPUSHUNDEF;
gv = MUTABLE_GV(POPs);
+ io = GvIO(gv);
- if (gv && (io = GvIO(gv))
+ if (io
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
{
- return tied_handle_method("FILENO", SP, io, mg);
+ return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
}
- if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
+ if (!io || !(fp = IoIFP(io))) {
/* Can't do this because people seem to do things like
defined(fileno($foo)) to check whether $foo is a valid fh.
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
+
+ report_evil_fh(gv);
*/
RETPUSHUNDEF;
}
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_ "BINMODE", SP, MUTABLE_SV(io), mg,
+ G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
+ discp ? 1 : 0, discp);
}
}
- if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
+ if (!io || !(fp = IoIFP(io))) {
+ report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
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
* 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) && !(sv = MUTABLE_SV(GvIOp(sv))))
+ if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHYES;
if ((mg = SvTIED_mg(sv, how))) {
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;
PP(pp_getc)
{
dVAR; dSP; dTARGET;
- IO *io = NULL;
- GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
+ GV * const gv =
+ MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
+ IO *const io = GvIO(gv);
if (MAXARG == 0)
EXTEND(SP, 1);
- if (gv && (io = GvIO(gv))) {
- MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
+ if (io) {
+ const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
const U32 gimme = GIMME_V;
- S_tied_handle_method(aTHX_ "GETC", SP, io, mg, gimme);
+ Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
if (gimme == G_SCALAR) {
SPAGAIN;
SvSetMagicSV_nosteal(TARG, TOPs);
}
}
if (!gv || do_eof(gv)) { /* make sure we have fp with something */
- if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
- && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
+ if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
+ report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
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");
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))
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");
}
fp = IoOFP(io);
if (!fp) {
- if (ckWARN2(WARN_CLOSED,WARN_IO)) {
- if (IoIFP(io))
- report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
- else if (ckWARN(WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
- }
+ if (IoIFP(io))
+ report_wrongway_fh(gv, '<');
+ else
+ report_evil_fh(gv);
PUSHs(&PL_sv_no);
}
else {
PP(pp_prtf)
{
dVAR; dSP; dMARK; dORIGMARK;
- IO *io;
PerlIO *fp;
SV *sv;
GV * const gv
= (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
+ IO *const io = GvIO(gv);
- if (gv && (io = GvIO(gv))) {
- MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
+ if (io) {
+ const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
if (MARK == ORIGMARK) {
MEXTEND(SP, 1);
Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
++SP;
}
- PUSHMARK(MARK - 1);
- *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
- PUTBACK;
- ENTER;
- call_method("PRINTF", G_SCALAR);
- LEAVE;
- SPAGAIN;
- MARK = ORIGMARK + 1;
- *MARK = *SP;
- SP = MARK;
- RETURN;
+ return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
+ mg,
+ G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
+ sp - mark);
}
}
sv = newSV(0);
- if (!(io = GvIO(gv))) {
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
+ if (!io) {
+ report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
- if (ckWARN2(WARN_CLOSED,WARN_IO)) {
- if (IoIFP(io))
- report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
- else if (ckWARN(WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
- }
+ if (IoIFP(io))
+ report_wrongway_fh(gv, '<');
+ else if (ckWARN(WARN_CLOSED))
+ report_evil_fh(gv);
SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
goto just_say_no;
}
else {
- if (SvTAINTED(MARK[1]))
- TAINT_PROPER("printf");
do_sprintf(sv, SP - MARK, MARK + 1);
if (!do_print(sv, fp))
goto just_say_no;
{
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) {
- SV *sv;
- PUSHMARK(MARK-1);
- *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
- ENTER;
- call_method("READ", G_SCALAR);
- LEAVE;
- SPAGAIN;
- sv = POPs;
- SP = ORIGMARK;
- PUSHs(sv);
- RETURN;
+ return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg,
+ G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
+ sp - mark);
}
}
offset = 0;
io = GvIO(gv);
if (!io || !IoIFP(io)) {
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
+ report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
goto say_undef;
}
#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);
(struct sockaddr *)namebuf, &bufsize);
if (count < 0)
RETPUSHUNDEF;
+ /* MSG_TRUNC can give oversized count; quietly lose it */
+ if (count > length)
+ count = length;
#ifdef EPOC
/* Bogus return without padding */
bufsize = sizeof (struct sockaddr_in);
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;
}
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);
count = -1;
}
if (count < 0) {
- if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
- report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
+ if (IoTYPE(io) == IoTYPE_WRONLY)
+ report_wrongway_fh(gv, '>');
goto say_undef;
}
SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
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);
- if (mg) {
- SV *sv;
+ IO *const io = GvIO(gv);
+ if (op_type == OP_SYSWRITE && io) {
+ const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
+ if (mg) {
if (MARK == SP - 1) {
- sv = *SP;
+ SV *sv = *SP;
mXPUSHi(sv_len(sv));
PUTBACK;
}
- PUSHMARK(ORIGMARK);
- *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
- ENTER;
- call_method("WRITE", G_SCALAR);
- LEAVE;
- SPAGAIN;
- sv = POPs;
- SP = ORIGMARK;
- PUSHs(sv);
- RETURN;
+ return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg,
+ G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
+ sp - mark);
}
}
if (!gv)
bufsv = *++MARK;
SETERRNO(0,0);
- io = GvIO(gv);
if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
retval = -1;
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
- if (io && IoIFP(io))
- report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
- else
- report_evil_fh(gv, io, PL_op->op_type);
- }
+ if (io && IoIFP(io))
+ report_wrongway_fh(gv, '<');
+ else
+ report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
goto say_undef;
}
}
}
- 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;
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("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("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("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 ((tmpgv = PL_op->op_flags & OPf_SPECIAL
+ ? gv_fetchsv(sv, 0, SVt_PVIO)
+ : MAYBE_DEREF_GV(sv) )) {
+ io = GvIO(tmpgv);
+ if (!io)
result = 0;
else {
PerlIO *fp;
- io = GvIOp(tmpgv);
do_ftruncate_io:
TAINT_PROPER("truncate");
if (!(fp = IoIFP(io))) {
}
}
}
- 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)
IV retval;
if (!io || !argsv || !IoIFP(io)) {
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
+ report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
RETPUSHUNDEF;
}
#ifdef FLOCK
dVAR; dSP; dTARGET;
I32 value;
- IO *io = NULL;
- PerlIO *fp;
const int argtype = POPi;
GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
+ IO *const io = GvIO(gv);
+ PerlIO *const fp = io ? IoIFP(io) : NULL;
- if (gv && (io = GvIO(gv)))
- fp = IoIFP(io);
- else {
- fp = NULL;
- io = NULL;
- }
/* XXX Looks to me like io is always NULL at this point */
if (fp) {
(void)PerlIO_flush(fp);
value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
}
else {
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
+ report_evil_fh(gv);
value = 0;
SETERRNO(EBADF,RMS_IFI);
}
/* Sockets. */
+#ifdef HAS_SOCKET
+
PP(pp_socket)
{
-#ifdef HAS_SOCKET
dVAR; dSP;
const int protocol = POPi;
const int type = POPi;
register IO * const io = gv ? GvIOn(gv) : NULL;
int fd;
- if (!gv || !io) {
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
+ if (!io) {
+ report_evil_fh(gv);
if (io && IoIFP(io))
do_close(gv, FALSE);
SETERRNO(EBADF,LIB_INVARG);
#endif
RETPUSHYES;
-#else
- DIE(aTHX_ PL_no_sock_func, "socket");
-#endif
}
+#endif
PP(pp_sockpair)
{
register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
int fd[2];
- if (!gv1 || !gv2 || !io1 || !io2) {
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
- if (!gv1 || !io1)
- report_evil_fh(gv1, io1, PL_op->op_type);
- if (!gv2 || !io2)
- report_evil_fh(gv1, io2, PL_op->op_type);
- }
- if (io1 && IoIFP(io1))
- do_close(gv1, FALSE);
- if (io2 && IoIFP(io2))
- do_close(gv2, FALSE);
- RETPUSHUNDEF;
- }
+ if (!io1)
+ report_evil_fh(gv1);
+ if (!io2)
+ report_evil_fh(gv2);
- if (IoIFP(io1))
+ if (io1 && IoIFP(io1))
do_close(gv1, FALSE);
- if (IoIFP(io2))
+ if (io2 && IoIFP(io2))
do_close(gv2, FALSE);
+ if (!io1 || !io2)
+ RETPUSHUNDEF;
+
TAINT_PROPER("socketpair");
if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
RETPUSHUNDEF;
#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? */
GV * const gv = MUTABLE_GV(POPs);
register IO * const io = GvIOn(gv);
STRLEN len;
+ const int op_type = PL_op->op_type;
if (!io || !IoIFP(io))
goto nuts;
addr = SvPV_const(addrsv, len);
- TAINT_PROPER("bind");
- if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
- RETPUSHYES;
- else
- RETPUSHUNDEF;
-
-nuts:
- if (ckWARN(WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,SS_IVCHAN);
- RETPUSHUNDEF;
-#else
- DIE(aTHX_ PL_no_sock_func, "bind");
-#endif
-}
-
-PP(pp_connect)
-{
-#ifdef HAS_SOCKET
- dVAR; dSP;
- SV * const addrsv = POPs;
- GV * const gv = MUTABLE_GV(POPs);
- register IO * const io = GvIOn(gv);
- const char *addr;
- STRLEN len;
-
- if (!io || !IoIFP(io))
- goto nuts;
-
- addr = SvPV_const(addrsv, len);
- TAINT_PROPER("connect");
- if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
+ TAINT_PROPER(PL_op_desc[op_type]);
+ if ((op_type == OP_BIND
+ ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
+ : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
+ >= 0)
RETPUSHYES;
else
RETPUSHUNDEF;
nuts:
- if (ckWARN(WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
+ report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
-#else
- DIE(aTHX_ PL_no_sock_func, "connect");
-#endif
}
PP(pp_listen)
{
-#ifdef HAS_SOCKET
dVAR; dSP;
const int backlog = POPi;
GV * const gv = MUTABLE_GV(POPs);
register IO * const io = gv ? GvIOn(gv) : NULL;
- if (!gv || !io || !IoIFP(io))
+ if (!io || !IoIFP(io))
goto nuts;
if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
RETPUSHUNDEF;
nuts:
- if (ckWARN(WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
+ report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
-#else
- DIE(aTHX_ PL_no_sock_func, "listen");
-#endif
}
PP(pp_accept)
{
-#ifdef HAS_SOCKET
dVAR; dSP; dTARGET;
register IO *nstio;
register IO *gstio;
RETURN;
nuts:
- if (ckWARN(WARN_CLOSED))
- report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
+ report_evil_fh(ggv);
SETERRNO(EBADF,SS_IVCHAN);
badexit:
RETPUSHUNDEF;
-#else
- DIE(aTHX_ PL_no_sock_func, "accept");
-#endif
}
PP(pp_shutdown)
{
-#ifdef HAS_SOCKET
dVAR; dSP; dTARGET;
const int how = POPi;
GV * const gv = MUTABLE_GV(POPs);
RETURN;
nuts:
- if (ckWARN(WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
+ report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
-#else
- DIE(aTHX_ PL_no_sock_func, "shutdown");
-#endif
}
PP(pp_ssockopt)
{
-#ifdef HAS_SOCKET
dVAR; dSP;
const int optype = PL_op->op_type;
SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
RETURN;
nuts:
- if (ckWARN(WARN_CLOSED))
- report_evil_fh(gv, io, optype);
+ report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
nuts2:
RETPUSHUNDEF;
-#else
- DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
-#endif
}
PP(pp_getpeername)
{
-#ifdef HAS_SOCKET
dVAR; dSP;
const int optype = PL_op->op_type;
GV * const gv = MUTABLE_GV(POPs);
RETURN;
nuts:
- if (ckWARN(WARN_CLOSED))
- report_evil_fh(gv, io, optype);
+ report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
nuts2:
RETPUSHUNDEF;
+}
-#else
- DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
#endif
-}
/* Stat calls. */
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;
}
if (PL_laststatval < 0) {
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, GvIO(gv), PL_op->op_type);
+ 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));
+ 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);
+#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
#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
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);
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;
conditional compiling below much clearer. */
I32 use_access = 0;
#endif
- int stat_mode = S_IRUSR;
+ Mode_t stat_mode = S_IRUSR;
bool effective = FALSE;
char opchar = '?';
I32 result;
tryAMAGICftest_MG('l');
+ STACKED_FTEST_CHECK;
result = my_lstat_flags(0);
SPAGAIN;
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);
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);
len = 512;
}
else {
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
- gv = cGVOP_gv;
- report_evil_fh(gv, GvIO(gv), PL_op->op_type);
- }
+ report_evil_fh(cGVOP_gv);
SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
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) ) {
PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
}
else {
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
+ report_evil_fh(gv);
SETERRNO(EBADF, RMS_IFI);
PUSHi(0);
}
}
else {
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
+ report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
PUSHi(0);
}
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 ((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)))
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;
}
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;
}
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 (!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 (!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
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
#endif
}
-#ifdef __GLIBC__
+#if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
# define PRIORITY_WHICH_T(which) (__priority_which_t)which
#else
# define PRIORITY_WHICH_T(which) which
{"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;
PUSHi(value);
RETURN;
#else
- return pp_semget();
+ return Perl_pp_semget(aTHX);
#endif
}
}
RETURN;
#else
- return pp_semget();
+ return Perl_pp_semget(aTHX);
#endif
}
}
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)
{
-#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_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_sock_func, "endservent");
+ DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
#endif
+ break;
+ }
+ EXTEND(SP,1);
+ RETPUSHYES;
}
PP(pp_gpwent)
const struct spwd * const spwent = getspnam(pwent->pw_name);
/* Save and restore errno so that
* underprivileged attempts seem
- * to have never made the unsccessful
+ * to have never made the unsuccessful
* attempt to retrieve the shadow password. */
RESTORE_ERRNO;
if (spwent && spwent->sp_pwdp)
#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