/* pp_sys.c
*
* Copyright (C) 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
void endservent(void);
#endif
-#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
-#undef PERL_EFF_ACCESS_W_OK
-#undef PERL_EFF_ACCESS_X_OK
+#undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
/* AIX 5.2 and below use mktime for localtime, and defines the edge case
* for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64
/* F_OK unused: if stat() cannot find it... */
-#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
+#if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
/* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
-# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
-# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
-# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
+# define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
#endif
-#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
+#if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
# ifdef I_SYS_SECURITY
# include <sys/security.h>
# endif
# ifdef ACC_SELF
/* HP SecureWare */
-# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
-# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
-# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
+# define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
# else
/* SCO */
-# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
-# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
-# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
+# define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
# endif
#endif
-#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
+#if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
/* AIX */
-# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
-# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
-# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
+# define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
#endif
-#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
+
+#if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
&& (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
|| defined(HAS_SETREGID) || defined(HAS_SETRESGID))
/* The Hard Way. */
return res;
}
-# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
-# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
-# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
+# define PERL_EFF_ACCESS(p,f) (emulate_eaccess((p), (f)))
#endif
-#if !defined(PERL_EFF_ACCESS_R_OK)
+#if !defined(PERL_EFF_ACCESS)
/* With it or without it: anyway you get a warning: either that
it is unused, or it is declared static and never defined.
*/
STATIC int
S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
{
- (void)path;
- (void)mode;
+ PERL_UNUSED_ARG(path);
+ PERL_UNUSED_ARG(mode);
Perl_croak(aTHX_ "switching effective uid is not implemented");
/*NOTREACHED*/
return -1;
PP(pp_backtick)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
PerlIO *fp;
const char * const tmps = POPpconstx;
const I32 gimme = GIMME_V;
mode = "rt";
fp = PerlProc_popen(tmps, mode);
if (fp) {
- const char *type = NULL;
- if (PL_curcop->cop_io) {
- type = SvPV_nolen_const(PL_curcop->cop_io);
- }
+ const char * const type = PL_curcop->cop_io ? SvPV_nolen_const(PL_curcop->cop_io) : NULL;
if (type && *type)
PerlIO_apply_layers(aTHX_ fp,mode,type);
SAVESPTR(PL_rs);
PL_rs = &PL_sv_undef;
sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
- while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
+ while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
;
LEAVE;
XPUSHs(TARG);
}
else {
for (;;) {
- SV * const sv = NEWSV(56, 79);
- if (sv_gets(sv, fp, 0) == Nullch) {
+ SV * const sv = newSV(79);
+ if (sv_gets(sv, fp, 0) == NULL) {
SvREFCNT_dec(sv);
break;
}
PL_last_in_gv = (GV*)*PL_stack_sp--;
SAVESPTR(PL_rs); /* This is not permanent, either. */
- PL_rs = sv_2mortal(newSVpvn("\000", 1));
+ PL_rs = sv_2mortal(newSVpvs("\000"));
#ifndef DOSISH
#ifndef CSH
*SvPVX(PL_rs) = '\n';
PP(pp_rcatline)
{
+ dVAR;
PL_last_in_gv = cGVOP_gv;
return do_readline();
}
PP(pp_warn)
{
- dSP; dMARK;
+ dVAR; dSP; dMARK;
SV *tmpsv;
const char *tmps;
STRLEN len;
- if (SP - MARK != 1) {
+ if (SP - MARK > 1) {
dTARGET;
do_join(TARG, &PL_sv_no, MARK, SP);
tmpsv = TARG;
SP = MARK + 1;
}
+ else if (SP == MARK) {
+ tmpsv = &PL_sv_no;
+ EXTEND(SP, 1);
+ }
else {
tmpsv = TOPs;
}
SV * const error = ERRSV;
SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
- sv_catpv(error, "\t...caught");
+ sv_catpvs(error, "\t...caught");
tmpsv = error;
tmps = SvPV_const(tmpsv, len);
}
if (!tmps || !len)
- tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
+ tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
Perl_warn(aTHX_ "%"SVf, tmpsv);
RETSETYES;
PP(pp_die)
{
- dSP; dMARK;
+ dVAR; dSP; dMARK;
const char *tmps;
SV *tmpsv;
STRLEN len;
}
else {
tmpsv = TOPs;
- tmps = SvROK(tmpsv) ? Nullch : SvPV_const(tmpsv, len);
+ tmps = SvROK(tmpsv) ? NULL : SvPV_const(tmpsv, len);
}
if (!tmps || !len) {
- SV *error = ERRSV;
+ SV * const error = ERRSV;
SvUPGRADE(error, SVt_PV);
if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
if (!multiarg)
SvSetSV(error,tmpsv);
else if (sv_isobject(error)) {
- HV *stash = SvSTASH(SvRV(error));
- GV *gv = gv_fetchmethod(stash, "PROPAGATE");
+ HV * const stash = SvSTASH(SvRV(error));
+ GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
if (gv) {
- SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
- SV *line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
+ 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(error);
sv_setsv(error,*PL_stack_sp--);
}
}
- DIE(aTHX_ Nullch);
+ DIE(aTHX_ NULL);
}
else {
if (SvPOK(error) && SvCUR(error))
- sv_catpv(error, "\t...propagated");
+ sv_catpvs(error, "\t...propagated");
tmpsv = error;
if (SvOK(tmpsv))
tmps = SvPV_const(tmpsv, len);
else
- tmps = Nullch;
+ tmps = NULL;
}
}
if (!tmps || !len)
- tmpsv = sv_2mortal(newSVpvn("Died", 4));
+ tmpsv = sv_2mortal(newSVpvs("Died"));
DIE(aTHX_ "%"SVf, tmpsv);
}
}
tmps = SvPV_const(sv, len);
- ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1, (SP-MARK));
+ ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
SP = ORIGMARK;
if (ok)
PUSHi( (I32)PL_forkprocess );
PP(pp_pipe_op)
{
#ifdef HAS_PIPE
+ dVAR;
dSP;
register IO *rstio;
register IO *wstio;
PP(pp_umask)
{
+ dVAR;
dSP;
#ifdef HAS_UMASK
dTARGET;
IO *io;
PerlIO *fp;
MAGIC *mg;
- SV *discp = Nullsv;
+ SV *discp = NULL;
if (MAXARG < 1)
RETPUSHUNDEF;
PUTBACK;
if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
- (discp) ? SvPV_nolen_const(discp) : Nullch)) {
+ (discp) ? SvPV_nolen_const(discp) : NULL)) {
if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io),
mode_from_discipline(discp),
- (discp) ? SvPV_nolen_const(discp) : Nullch)) {
+ (discp) ? SvPV_nolen_const(discp) : NULL)) {
SPAGAIN;
RETPUSHUNDEF;
}
SvTYPE(varsv) == SVt_PVHV))
Perl_croak(aTHX_
"Self-ties of arrays and hashes are not supported");
- sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
+ sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
}
LEAVE;
SP = PL_stack_base + markoff;
if ((mg = SvTIED_mg(sv, how))) {
SV * const obj = SvRV(SvTIED_obj(sv, mg));
- CV *cv = NULL;
if (obj) {
GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
+ CV *cv;
if (gv && isGV(gv) && (cv = GvCV(gv))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
PP(pp_tied)
{
+ dVAR;
dSP;
const MAGIC *mg;
SV *sv = POPs;
GV *gv;
HV * const hv = (HV*)POPs;
- SV * const sv = sv_mortalcopy(&PL_sv_no);
-
- sv_setpv(sv, "AnyDBM_File");
+ SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
stash = gv_stashsv(sv, FALSE);
if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
PUTBACK;
if (sv_isobject(TOPs)) {
sv_unmagic((SV *) hv, PERL_MAGIC_tied);
- sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, Nullch, 0);
+ sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
}
LEAVE;
RETURN;
PP(pp_sselect)
{
#ifdef HAS_SELECT
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
register I32 i;
register I32 j;
register char *s;
timebuf.tv_usec = (long)(value * 1000000.0);
}
else
- tbuf = Null(struct timeval*);
+ tbuf = NULL;
for (i = 1; i <= 3; i++) {
sv = SP[i];
if (GIMME == G_ARRAY && tbuf) {
value = (NV)(timebuf.tv_sec) +
(NV)(timebuf.tv_usec) / 1000000.0;
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setnv(sv, value);
+ PUSHs(sv_2mortal(newSVnv(value)));
}
RETURN;
#else
void
Perl_setdefout(pTHX_ GV *gv)
{
- if (gv)
- (void)SvREFCNT_inc(gv);
+ dVAR;
+ SvREFCNT_inc_simple_void(gv);
if (PL_defoutgv)
SvREFCNT_dec(PL_defoutgv);
PL_defoutgv = gv;
PP(pp_select)
{
- dSP; dTARGET;
- GV *egv;
+ dVAR; dSP; dTARGET;
HV *hv;
-
GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
+ GV * egv = GvEGV(PL_defoutgv);
- egv = GvEGV(PL_defoutgv);
if (!egv)
egv = PL_defoutgv;
hv = GvSTASH(egv);
else {
GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
if (gvp && *gvp == egv) {
- gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE);
+ gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
XPUSHTARG;
}
else {
PP(pp_enterwrite)
{
+ dVAR;
dSP;
register GV *gv;
register IO *io;
if (fgv) {
SV * const tmpsv = sv_newmortal();
const char *name;
- gv_efullname4(tmpsv, fgv, Nullch, FALSE);
+ gv_efullname4(tmpsv, fgv, NULL, FALSE);
name = SvPV_nolen_const(tmpsv);
if (name && *name)
DIE(aTHX_ "Undefined format \"%s\" called", name);
if (!IoFMT_NAME(io))
IoFMT_NAME(io) = savepv(GvNAME(gv));
topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
- topgv = gv_fetchsv(topname, FALSE, SVt_PVFM);
+ topgv = gv_fetchsv(topname, 0, SVt_PVFM);
if ((topgv && GvFORM(topgv)) ||
- !gv_fetchpv("top",FALSE,SVt_PVFM))
+ !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
IoTOP_NAME(io) = savesvpv(topname);
else
- IoTOP_NAME(io) = savepvn("top", 3);
+ IoTOP_NAME(io) = savepvs("top");
}
- topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
+ topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
if (!topgv || !GvFORM(topgv)) {
IoLINES_LEFT(io) = IoPAGE_LEN(io);
goto forget_top;
if (!cv) {
SV * const sv = sv_newmortal();
const char *name;
- gv_efullname4(sv, fgv, Nullch, FALSE);
+ gv_efullname4(sv, fgv, NULL, FALSE);
name = SvPV_nolen_const(sv);
if (name && *name)
DIE(aTHX_ "Undefined top format \"%s\" called",name);
RETURN;
}
- sv = NEWSV(0,0);
+ sv = newSV(0);
if (!(io = GvIO(gv))) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
PP(pp_sysopen)
{
+ dVAR;
dSP;
const int perm = (MAXARG > 3) ? POPi : 0666;
const int mode = POPi;
/* Need TIEHANDLE method ? */
const char * const tmps = SvPV_const(sv, len);
/* FIXME? do_open should do const */
- if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
+ if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
IoLINES(GvIOp(gv)) = 0;
PUSHs(&PL_sv_yes);
}
RETPUSHUNDEF;
}
-PP(pp_syswrite)
-{
- dVAR; dSP;
- const int items = (SP - PL_stack_base) - TOPMARK;
- if (items == 2) {
- SV *sv;
- EXTEND(SP, 1);
- sv = sv_2mortal(newSViv(sv_len(*SP)));
- PUSHs(sv);
- PUTBACK;
- }
- return pp_send();
-}
-
PP(pp_send)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- GV *gv;
IO *io;
SV *bufsv;
const char *buffer;
- Size_t length;
+ Size_t length = 0;
SSize_t retval;
STRLEN blen;
MAGIC *mg;
-
- gv = (GV*)*++MARK;
+ const int op_type = PL_op->op_type;
+
+ GV *const gv = (GV*)*++MARK;
if (PL_op->op_type == OP_SYSWRITE
&& gv && (io = GvIO(gv))
&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
{
SV *sv;
+
+ if (MARK == SP - 1) {
+ EXTEND(SP, 1000);
+ sv = sv_2mortal(newSViv(sv_len(*SP)));
+ PUSHs(sv);
+ PUTBACK;
+ }
- PUSHMARK(MARK-1);
- *MARK = SvTIED_obj((SV*)io, mg);
+ PUSHMARK(ORIGMARK);
+ *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
ENTER;
call_method("WRITE", G_SCALAR);
LEAVE;
}
if (!gv)
goto say_undef;
+
bufsv = *++MARK;
+
+ if (op_type == OP_SYSWRITE) {
+ if (MARK >= SP) {
+ length = (Size_t) sv_len(bufsv);
+ } else {
#if Size_t_size > IVSIZE
- length = (Size_t)SvNVx(*++MARK);
+ length = (Size_t)SvNVx(*++MARK);
#else
- length = (Size_t)SvIVx(*++MARK);
+ length = (Size_t)SvIVx(*++MARK);
#endif
- if ((SSize_t)length < 0)
- DIE(aTHX_ "Negative length");
+ if ((SSize_t)length < 0)
+ DIE(aTHX_ "Negative length");
+ }
+ }
SETERRNO(0,0);
io = GvIO(gv);
if (!io || !IoIFP(io)) {
buffer = SvPV_const(bufsv, blen);
}
- if (PL_op->op_type == OP_SYSWRITE) {
+ if (op_type == OP_SYSWRITE) {
IV offset;
if (DO_UTF8(bufsv)) {
/* length and offset are in chars */
}
}
#ifdef HAS_SOCKET
- else if (SP > MARK) {
- STRLEN mlen;
- char * const sockbuf = SvPVx(*++MARK, mlen);
- /* length is really flags */
- retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
- length, (struct sockaddr *)sockbuf, mlen);
+ 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
- /* length is really flags */
- retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
#else
else
DIE(aTHX_ PL_no_sock_func, "send");
{
dVAR; dSP;
GV *gv;
- IO *io;
- MAGIC *mg;
if (MAXARG == 0) {
if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
IoLINES(io) = 0;
IoFLAGS(io) &= ~IOf_START;
- do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
+ do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
sv_setpvn(GvSV(gv), "-", 1);
SvSETMAGIC(GvSV(gv));
}
else
gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
- if (gv && (io = GvIO(gv))
- && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
- {
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)io, mg));
- PUTBACK;
- ENTER;
- call_method("EOF", G_SCALAR);
- LEAVE;
- SPAGAIN;
- RETURN;
+ if (gv) {
+ IO * const io = GvIO(gv);
+ MAGIC * mg;
+ if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ PUTBACK;
+ ENTER;
+ call_method("EOF", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
}
PUSHs(boolSV(!gv || do_eof(gv)));
PP(pp_sysseek)
{
dVAR; dSP;
- GV *gv;
IO *io;
const int whence = POPi;
#if LSEEKSIZE > IVSIZE
- Off_t offset = (Off_t)SvNVx(POPs);
+ const Off_t offset = (Off_t)SvNVx(POPs);
#else
- Off_t offset = (Off_t)SvIVx(POPs);
+ const Off_t offset = (Off_t)SvIVx(POPs);
#endif
MAGIC *mg;
- gv = PL_last_in_gv = (GV*)POPs;
+ GV * const gv = PL_last_in_gv = (GV*)POPs;
if (gv && (io = GvIO(gv))
&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
if (PL_op->op_type == OP_SEEK)
PUSHs(boolSV(do_seek(gv, offset, whence)));
else {
- Off_t sought = do_sysseek(gv, offset, whence);
+ const Off_t sought = do_sysseek(gv, offset, whence);
if (sought < 0)
PUSHs(&PL_sv_undef);
else {
- SV* sv = sought ?
+ SV* const sv = sought ?
#if LSEEKSIZE > IVSIZE
newSVnv((NV)sought)
#else
PP(pp_truncate)
{
+ dVAR;
dSP;
/* There seems to be no consensus on the length type of truncate()
* and ftruncate(), both off_t and size_t have supporters. In
IO *io;
if (PL_op->op_flags & OPf_SPECIAL) {
- tmpgv = gv_fetchsv(POPs, FALSE, SVt_PVIO);
+ tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
do_ftruncate_gv:
if (!GvIO(tmpgv))
}
}
else {
- SV *sv = POPs;
+ SV * const sv = POPs;
const char *name;
if (SvTYPE(sv) == SVt_PVGV) {
result = 0;
#else
{
- int tmpfd;
+ const int tmpfd = PerlLIO_open(name, O_RDWR);
- if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
+ if (tmpfd < 0)
result = 0;
else {
if (my_chsize(tmpfd, len) < 0)
PP(pp_ioctl)
{
- dSP; dTARGET;
- SV *argsv = POPs;
+ dVAR; dSP; dTARGET;
+ SV * const argsv = POPs;
const unsigned int func = POPu;
const int optype = PL_op->op_type;
+ GV * const gv = (GV*)POPs;
+ IO * const io = gv ? GvIOn(gv) : NULL;
char *s;
IV retval;
- GV *gv = (GV*)POPs;
- IO *io = gv ? GvIOn(gv) : 0;
if (!io || !argsv || !IoIFP(io)) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
s = INT2PTR(char*,retval); /* ouch */
}
- TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
+ TAINT_PROPER(PL_op_desc[optype]);
if (optype == OP_IOCTL)
#ifdef HAS_IOCTL
PP(pp_flock)
{
#ifdef FLOCK
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
I32 value;
- int argtype;
- GV *gv;
IO *io = NULL;
PerlIO *fp;
+ const int argtype = POPi;
+ GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
- argtype = POPi;
- if (MAXARG == 0)
- gv = PL_last_in_gv;
- else
- gv = (GV*)POPs;
if (gv && (io = GvIO(gv)))
fp = IoIFP(io);
else {
- fp = Nullfp;
+ 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);
PP(pp_socket)
{
#ifdef HAS_SOCKET
- dSP;
- GV *gv;
- register IO *io;
- int protocol = POPi;
- int type = POPi;
- int domain = POPi;
+ dVAR; dSP;
+ const int protocol = POPi;
+ const int type = POPi;
+ const int domain = POPi;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = gv ? GvIOn(gv) : NULL;
int fd;
- gv = (GV*)POPs;
- io = gv ? GvIOn(gv) : NULL;
-
if (!gv || !io) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- if (IoIFP(io))
+ if (io && IoIFP(io))
do_close(gv, FALSE);
SETERRNO(EBADF,LIB_INVARG);
RETPUSHUNDEF;
PP(pp_sockpair)
{
#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
- dSP;
- GV *gv1;
- GV *gv2;
- register IO *io1;
- register IO *io2;
- int protocol = POPi;
- int type = POPi;
- int domain = POPi;
+ dVAR; dSP;
+ const int protocol = POPi;
+ const int type = POPi;
+ const int domain = POPi;
+ GV * const gv2 = (GV*)POPs;
+ GV * const gv1 = (GV*)POPs;
+ register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
+ register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
int fd[2];
- gv2 = (GV*)POPs;
- gv1 = (GV*)POPs;
- io1 = gv1 ? GvIOn(gv1) : NULL;
- io2 = gv2 ? GvIOn(gv2) : NULL;
if (!gv1 || !gv2 || !io1 || !io2) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
if (!gv1 || !io1)
if (!gv2 || !io2)
report_evil_fh(gv1, io2, PL_op->op_type);
}
- if (IoIFP(io1))
+ if (io1 && IoIFP(io1))
do_close(gv1, FALSE);
- if (IoIFP(io2))
+ if (io2 && IoIFP(io2))
do_close(gv2, FALSE);
RETPUSHUNDEF;
}
PP(pp_bind)
{
#ifdef HAS_SOCKET
- dSP;
-#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
- extern void GETPRIVMODE();
- extern void GETUSERMODE();
-#endif
- SV *addrsv = POPs;
+ dVAR; dSP;
+ SV * const addrsv = POPs;
/* OK, so on what platform does bind modify addr? */
const char *addr;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
STRLEN len;
int bind_ok = 0;
-#ifdef MPE
- int mpeprivmode = 0;
-#endif
if (!io || !IoIFP(io))
goto nuts;
addr = SvPV_const(addrsv, len);
TAINT_PROPER("bind");
-#ifdef MPE /* Deal with MPE bind() peculiarities */
- if (((struct sockaddr *)addr)->sa_family == AF_INET) {
- /* The address *MUST* stupidly be zero. */
- ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
- /* PRIV mode is required to bind() to ports < 1024. */
- if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
- ((struct sockaddr_in *)addr)->sin_port > 0) {
- GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
- mpeprivmode = 1;
- }
- }
-#endif /* MPE */
if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
(struct sockaddr *)addr, len) >= 0)
bind_ok = 1;
-#ifdef MPE /* Switch back to USER mode */
- if (mpeprivmode)
- GETUSERMODE();
-#endif /* MPE */
if (bind_ok)
RETPUSHYES;
PP(pp_connect)
{
#ifdef HAS_SOCKET
- dSP;
- SV *addrsv = POPs;
+ dVAR; dSP;
+ SV * const addrsv = POPs;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
const char *addr;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
STRLEN len;
if (!io || !IoIFP(io))
PP(pp_listen)
{
#ifdef HAS_SOCKET
- dSP;
- int backlog = POPi;
- GV *gv = (GV*)POPs;
- register IO *io = gv ? GvIOn(gv) : NULL;
+ dVAR; dSP;
+ const int backlog = POPi;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = gv ? GvIOn(gv) : NULL;
if (!gv || !io || !IoIFP(io))
goto nuts;
PP(pp_accept)
{
#ifdef HAS_SOCKET
- dSP; dTARGET;
- GV *ngv;
- GV *ggv;
+ dVAR; dSP; dTARGET;
register IO *nstio;
register IO *gstio;
char namebuf[MAXPATHLEN];
#else
Sock_size_t len = sizeof namebuf;
#endif
+ GV * const ggv = (GV*)POPs;
+ GV * const ngv = (GV*)POPs;
int fd;
- ggv = (GV*)POPs;
- ngv = (GV*)POPs;
-
if (!ngv)
goto badexit;
if (!ggv)
PP(pp_shutdown)
{
#ifdef HAS_SOCKET
- dSP; dTARGET;
- int how = POPi;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ dVAR; dSP; dTARGET;
+ const int how = POPi;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
if (!io || !IoIFP(io))
goto nuts;
PP(pp_ssockopt)
{
#ifdef HAS_SOCKET
- dSP;
- int optype = PL_op->op_type;
- SV *sv;
+ 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 = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
int fd;
- unsigned int optname;
- unsigned int lvl;
- GV *gv;
- register IO *io;
Sock_size_t len;
- if (optype == OP_GSOCKOPT)
- sv = sv_2mortal(NEWSV(22, 257));
- else
- sv = POPs;
- optname = (unsigned int) POPi;
- lvl = (unsigned int) POPi;
-
- gv = (GV*)POPs;
- io = GvIOn(gv);
if (!io || !IoIFP(io))
goto nuts;
PP(pp_getpeername)
{
#ifdef HAS_SOCKET
- dSP;
- int optype = PL_op->op_type;
+ dVAR; dSP;
+ const int optype = PL_op->op_type;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
+ Sock_size_t len;
SV *sv;
int fd;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
- Sock_size_t len;
if (!io || !IoIFP(io))
goto nuts;
- sv = sv_2mortal(NEWSV(22, 257));
+ sv = sv_2mortal(newSV(257));
(void)SvPOK_only(sv);
len = 256;
SvCUR_set(sv, len);
PP(pp_stat)
{
+ dVAR;
dSP;
GV *gv;
I32 gimme;
gv = cGVOP_gv;
if (PL_op->op_type == OP_LSTAT) {
if (gv != PL_defgv) {
+ do_fstat_warning_check:
if (ckWARN(WARN_IO))
Perl_warner(aTHX_ packWARN(WARN_IO),
"lstat() on filehandle %s", GvENAME(gv));
}
}
else {
- SV* sv = POPs;
+ SV* const sv = POPs;
if (SvTYPE(sv) == SVt_PVGV) {
gv = (GV*)sv;
goto do_fstat;
}
else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
gv = (GV*)SvRV(sv);
- if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO))
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "lstat() on filehandle %s", GvENAME(gv));
+ if (PL_op->op_type == OP_LSTAT)
+ goto do_fstat_warning_check;
goto do_fstat;
}
sv_setpv(PL_statname, SvPV_nolen_const(sv));
- PL_statgv = Nullgv;
+ PL_statgv = NULL;
PL_laststype = PL_op->op_type;
if (PL_op->op_type == OP_LSTAT)
PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
#ifdef USE_STAT_RDEV
PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
#else
- PUSHs(sv_2mortal(newSVpvn("", 0)));
+ PUSHs(sv_2mortal(newSVpvs("")));
#endif
#if Off_t_size > IVSIZE
PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
#else
- PUSHs(sv_2mortal(newSVpvn("", 0)));
- PUSHs(sv_2mortal(newSVpvn("", 0)));
+ PUSHs(sv_2mortal(newSVpvs("")));
+ PUSHs(sv_2mortal(newSVpvs("")));
#endif
}
RETURN;
PP(pp_ftrread)
{
+ dVAR;
I32 result;
- dSP;
- STACKED_FTEST_CHECK;
-#if defined(HAS_ACCESS) && defined(R_OK)
- if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
- result = access(POPpx, R_OK);
- if (result == 0)
- RETPUSHYES;
- if (result < 0)
- RETPUSHUNDEF;
- RETPUSHNO;
- }
- else
- result = my_stat();
+ /* Not const, because things tweak this below. Not bool, because there's
+ no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
+#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
+ I32 use_access = PL_op->op_private & OPpFT_ACCESS;
+ /* Giving some sort of initial value silences compilers. */
+# ifdef R_OK
+ int access_mode = R_OK;
+# else
+ int access_mode = 0;
+# endif
#else
- result = my_stat();
+ /* access_mode is never used, but leaving use_access in makes the
+ conditional compiling below much clearer. */
+ I32 use_access = 0;
#endif
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (cando(S_IRUSR, 0, &PL_statcache))
- RETPUSHYES;
- RETPUSHNO;
-}
+ int stat_mode = S_IRUSR;
-PP(pp_ftrwrite)
-{
- I32 result;
+ bool effective = FALSE;
dSP;
+
STACKED_FTEST_CHECK;
+
+ switch (PL_op->op_type) {
+ case OP_FTRREAD:
+#if !(defined(HAS_ACCESS) && defined(R_OK))
+ use_access = 0;
+#endif
+ break;
+
+ case OP_FTRWRITE:
#if defined(HAS_ACCESS) && defined(W_OK)
- if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
- result = access(POPpx, W_OK);
- if (result == 0)
- RETPUSHYES;
- if (result < 0)
- RETPUSHUNDEF;
- RETPUSHNO;
- }
- else
- result = my_stat();
+ access_mode = W_OK;
#else
- result = my_stat();
+ use_access = 0;
#endif
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (cando(S_IWUSR, 0, &PL_statcache))
- RETPUSHYES;
- RETPUSHNO;
-}
+ stat_mode = S_IWUSR;
+ break;
-PP(pp_ftrexec)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
+ case OP_FTREXEC:
#if defined(HAS_ACCESS) && defined(X_OK)
- if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
- result = access(POPpx, X_OK);
- if (result == 0)
- RETPUSHYES;
- if (result < 0)
- RETPUSHUNDEF;
- RETPUSHNO;
- }
- else
- result = my_stat();
+ access_mode = X_OK;
#else
- result = my_stat();
+ use_access = 0;
#endif
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (cando(S_IXUSR, 0, &PL_statcache))
- RETPUSHYES;
- RETPUSHNO;
-}
+ stat_mode = S_IXUSR;
+ break;
-PP(pp_fteread)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
-#ifdef PERL_EFF_ACCESS_R_OK
- if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
- result = PERL_EFF_ACCESS_R_OK(POPpx);
- if (result == 0)
- RETPUSHYES;
- if (result < 0)
- RETPUSHUNDEF;
- RETPUSHNO;
- }
- else
- result = my_stat();
-#else
- result = my_stat();
+ case OP_FTEWRITE:
+#ifdef PERL_EFF_ACCESS
+ access_mode = W_OK;
#endif
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (cando(S_IRUSR, 1, &PL_statcache))
- RETPUSHYES;
- RETPUSHNO;
-}
+ stat_mode = S_IWUSR;
+ /* Fall through */
-PP(pp_ftewrite)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
-#ifdef PERL_EFF_ACCESS_W_OK
- if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
- result = PERL_EFF_ACCESS_W_OK(POPpx);
- if (result == 0)
- RETPUSHYES;
- if (result < 0)
- RETPUSHUNDEF;
- RETPUSHNO;
- }
- else
- result = my_stat();
+ case OP_FTEREAD:
+#ifndef PERL_EFF_ACCESS
+ use_access = 0;
+#endif
+ effective = TRUE;
+ break;
+
+
+ case OP_FTEEXEC:
+#ifdef PERL_EFF_ACCESS
+ access_mode = W_OK;
#else
- result = my_stat();
+ use_access = 0;
#endif
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (cando(S_IWUSR, 1, &PL_statcache))
- RETPUSHYES;
- RETPUSHNO;
-}
+ stat_mode = S_IXUSR;
+ effective = TRUE;
+ break;
+ }
-PP(pp_fteexec)
-{
- I32 result;
- dSP;
- STACKED_FTEST_CHECK;
-#ifdef PERL_EFF_ACCESS_X_OK
- if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
- result = PERL_EFF_ACCESS_X_OK(POPpx);
+ if (use_access) {
+#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
+ const char *const name = POPpx;
+ if (effective) {
+# ifdef PERL_EFF_ACCESS
+ result = PERL_EFF_ACCESS(name, access_mode);
+# else
+ DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
+ OP_NAME(PL_op));
+# endif
+ }
+ else {
+# ifdef HAS_ACCESS
+ result = access(name, access_mode);
+# else
+ DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
+# endif
+ }
if (result == 0)
RETPUSHYES;
if (result < 0)
RETPUSHUNDEF;
RETPUSHNO;
+#endif
}
- else
- result = my_stat();
-#else
+
result = my_stat();
-#endif
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- if (cando(S_IXUSR, 1, &PL_statcache))
+ if (cando(stat_mode, effective, &PL_statcache))
RETPUSHYES;
RETPUSHNO;
}
PP(pp_ftis)
{
+ dVAR;
I32 result;
const int op_type = PL_op->op_type;
dSP;
PP(pp_ftrowned)
{
+ dVAR;
I32 result;
dSP;
RETPUSHUNDEF;
switch (PL_op->op_type) {
case OP_FTROWNED:
- if (PL_statcache.st_uid == PL_uid);
+ if (PL_statcache.st_uid == PL_uid)
RETPUSHYES;
break;
case OP_FTEOWNED:
PP(pp_ftlink)
{
+ dVAR;
I32 result = my_lstat();
dSP;
if (result < 0)
PP(pp_fttty)
{
+ dVAR;
dSP;
int fd;
GV *gv;
- SV *tmpsv = Nullsv;
+ SV *tmpsv = NULL;
STACKED_FTEST_CHECK;
else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
gv = (GV*)SvRV(POPs);
else
- gv = gv_fetchsv(tmpsv = POPs, FALSE, SVt_PVIO);
+ gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
if (GvIO(gv) && IoIFP(GvIOp(gv)))
fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
PP(pp_fttext)
{
+ dVAR;
dSP;
I32 i;
I32 len;
else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
gv = (GV*)SvRV(POPs);
else
- gv = Nullgv;
+ gv = NULL;
if (gv) {
EXTEND(SP, 1);
else {
sv = POPs;
really_filename:
- PL_statgv = Nullgv;
+ PL_statgv = NULL;
PL_laststype = OP_STAT;
sv_setpv(PL_statname, SvPV_nolen_const(sv));
if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
(void)PerlIO_close(fp);
RETPUSHUNDEF;
}
- PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
+ PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
len = PerlIO_read(fp, tbuf, sizeof(tbuf));
(void)PerlIO_close(fp);
if (len <= 0) {
PP(pp_chdir)
{
- dSP; dTARGET;
- const char *tmps = 0;
+ dVAR; dSP; dTARGET;
+ const char *tmps = NULL;
GV *gv = NULL;
if( MAXARG == 1 ) {
SV * const sv = POPs;
- if (SvTYPE(sv) == SVt_PVGV) {
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ gv = gv_fetchsv(sv, 0, SVt_PVIO);
+ }
+ else if (SvTYPE(sv) == SVt_PVGV) {
gv = (GV*)sv;
}
else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
HV * const table = GvHVn(PL_envgv);
SV **svp;
- if ( (svp = hv_fetch(table, "HOME", 4, FALSE))
- || (svp = hv_fetch(table, "LOGDIR", 6, FALSE))
+ if ( (svp = hv_fetchs(table, "HOME", FALSE))
+ || (svp = hv_fetchs(table, "LOGDIR", FALSE))
#ifdef VMS
- || (svp = hv_fetch(table, "SYS$LOGIN", 9, FALSE))
+ || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
#endif
)
{
#endif
}
else {
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF, RMS_IFI);
PUSHi(0);
}
}
else {
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,RMS_IFI);
PUSHi(0);
}
#else
PP(pp_chown)
{
- dSP; dMARK; dTARGET;
+ dVAR; dSP; dMARK; dTARGET;
const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
SP = MARK;
- PUSHi(value);
+ XPUSHi(value);
RETURN;
}
PP(pp_chroot)
{
#ifdef HAS_CHROOT
- dSP; dTARGET;
- char *tmps = POPpx;
+ dVAR; dSP; dTARGET;
+ char * const tmps = POPpx;
TAINT_PROPER("chroot");
PUSHi( chroot(tmps) >= 0 );
RETURN;
PP(pp_rename)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
int anum;
- const char *tmps2 = POPpconstx;
- const char *tmps = SvPV_nolen_const(TOPs);
+ const char * const tmps2 = POPpconstx;
+ const char * const tmps = SvPV_nolen_const(TOPs);
TAINT_PROPER("rename");
#ifdef HAS_RENAME
anum = PerlLIO_rename(tmps, tmps2);
RETURN;
}
+#if defined(HAS_LINK) || defined(HAS_SYMLINK)
PP(pp_link)
{
-#ifdef HAS_LINK
- dSP; dTARGET;
- const char *tmps2 = POPpconstx;
- const char *tmps = SvPV_nolen_const(TOPs);
- TAINT_PROPER("link");
- SETi( PerlLIO_link(tmps, tmps2) >= 0 );
- RETURN;
-#else
- DIE(aTHX_ PL_no_func, "link");
-#endif
-}
+ dVAR; dSP; dTARGET;
+ const int op_type = PL_op->op_type;
+ int result;
-PP(pp_symlink)
-{
-#ifdef HAS_SYMLINK
- dSP; dTARGET;
- const char *tmps2 = POPpconstx;
- const char *tmps = SvPV_nolen_const(TOPs);
- TAINT_PROPER("symlink");
- SETi( symlink(tmps, tmps2) >= 0 );
+# ifndef HAS_LINK
+ if (op_type == OP_LINK)
+ DIE(aTHX_ PL_no_func, "link");
+# endif
+# ifndef HAS_SYMLINK
+ if (op_type == OP_SYMLINK)
+ DIE(aTHX_ PL_no_func, "symlink");
+# endif
+
+ {
+ const char * const tmps2 = POPpconstx;
+ const char * const tmps = SvPV_nolen_const(TOPs);
+ TAINT_PROPER(PL_op_desc[op_type]);
+ result =
+# if defined(HAS_LINK)
+# if defined(HAS_SYMLINK)
+ /* Both present - need to choose which. */
+ (op_type == OP_LINK) ?
+ PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
+# else
+ /* Only have link, so calls to pp_symlink will have DIE()d above. */
+ PerlLIO_link(tmps, tmps2);
+# endif
+# else
+# if defined(HAS_SYMLINK)
+ /* Only have symlink, so calls to pp_link will have DIE()d above. */
+ symlink(tmps, tmps2);
+# endif
+# endif
+ }
+
+ SETi( result >= 0 );
RETURN;
+}
#else
- DIE(aTHX_ PL_no_func, "symlink");
-#endif
+PP(pp_link)
+{
+ /* Have neither. */
+ DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
}
+#endif
PP(pp_readlink)
{
+ dVAR;
dSP;
#ifdef HAS_SYMLINK
dTARGET;
Safefree(cmdline);
if (myfp) {
- SV *tmpsv = sv_newmortal();
+ SV * const tmpsv = sv_newmortal();
/* Need to save/restore 'PL_rs' ?? */
s = sv_gets(tmpsv, myfp, 0);
(void)PerlProc_pclose(myfp);
- if (s != Nullch) {
+ if (s != NULL) {
int e;
for (e = 1;
#ifdef HAS_SYS_ERRLIST
; e++)
{
/* you don't see this */
- char *errmsg =
+ const char * const errmsg =
#ifdef HAS_SYS_ERRLIST
sys_errlist[e]
#else
PP(pp_mkdir)
{
- dSP; dTARGET;
- int mode;
-#ifndef HAS_MKDIR
- int oldumask;
-#endif
+ dVAR; dSP; dTARGET;
STRLEN len;
const char *tmps;
bool copy = FALSE;
-
- if (MAXARG > 1)
- mode = POPi;
- else
- mode = 0777;
+ const int mode = (MAXARG > 1) ? POPi : 0777;
TRIMSLASHES(tmps,len,copy);
#ifdef HAS_MKDIR
SETi( PerlDir_mkdir(tmps, mode) >= 0 );
#else
+ {
+ int oldumask;
SETi( dooneliner("mkdir", tmps) );
oldumask = PerlLIO_umask(0);
PerlLIO_umask(oldumask);
PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
+ }
#endif
if (copy)
Safefree(tmps);
PP(pp_rmdir)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
STRLEN len;
const char *tmps;
bool copy = FALSE;
PP(pp_open_dir)
{
#if defined(Direntry_t) && defined(HAS_READDIR)
- dSP;
- const char *dirname = POPpconstx;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ dVAR; dSP;
+ const char * const dirname = POPpconstx;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
if (!io)
goto nope;
#if !defined(I_DIRENT) && !defined(VMS)
Direntry_t *readdir (DIR *);
#endif
+ dVAR;
dSP;
SV *sv;
const I32 gimme = GIMME;
- GV *gv = (GV *)POPs;
- register Direntry_t *dp;
- register IO *io = GvIOn(gv);
+ GV * const gv = (GV *)POPs;
+ register const Direntry_t *dp;
+ register IO * const io = GvIOn(gv);
- if (!io || !IoDIRP(io))
- goto nope;
+ if (!io || !IoDIRP(io)) {
+ if(ckWARN(WARN_IO)) {
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
+ }
+ goto nope;
+ }
do {
dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
long telldir (DIR *);
# endif
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
- if (!io || !IoDIRP(io))
- goto nope;
+ if (!io || !IoDIRP(io)) {
+ if(ckWARN(WARN_IO)) {
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
+ }
+ goto nope;
+ }
PUSHi( PerlDir_tell(IoDIRP(io)) );
RETURN;
PP(pp_seekdir)
{
#if defined(HAS_SEEKDIR) || defined(seekdir)
- dSP;
- long along = POPl;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
-
- if (!io || !IoDIRP(io))
- goto nope;
-
+ dVAR; dSP;
+ const long along = POPl;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
+
+ if (!io || !IoDIRP(io)) {
+ if(ckWARN(WARN_IO)) {
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
+ }
+ goto nope;
+ }
(void)PerlDir_seek(IoDIRP(io), along);
RETPUSHYES;
PP(pp_rewinddir)
{
#if defined(HAS_REWINDDIR) || defined(rewinddir)
- dSP;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ dVAR; dSP;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
- if (!io || !IoDIRP(io))
+ if (!io || !IoDIRP(io)) {
+ if(ckWARN(WARN_IO)) {
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
+ }
goto nope;
-
+ }
(void)PerlDir_rewind(IoDIRP(io));
RETPUSHYES;
nope:
PP(pp_closedir)
{
#if defined(Direntry_t) && defined(HAS_READDIR)
- dSP;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
-
- if (!io || !IoDIRP(io))
- goto nope;
+ dVAR; dSP;
+ GV * const gv = (GV*)POPs;
+ register IO * const io = GvIOn(gv);
+ if (!io || !IoDIRP(io)) {
+ if(ckWARN(WARN_IO)) {
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
+ }
+ goto nope;
+ }
#ifdef VOID_CLOSEDIR
PerlDir_close(IoDIRP(io));
#else
PP(pp_fork)
{
#ifdef HAS_FORK
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
Pid_t childpid;
- GV *tmpgv;
EXTEND(SP, 1);
PERL_FLUSHALL_FOR_CHILD;
if (childpid < 0)
RETSETUNDEF;
if (!childpid) {
- if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) {
+ 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));
PP(pp_wait)
{
#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
Pid_t childpid;
int argflags;
PP(pp_waitpid)
{
#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
- dSP; dTARGET;
- Pid_t pid;
+ dVAR; dSP; dTARGET;
+ const int optype = POPi;
+ const Pid_t pid = TOPi;
Pid_t result;
- int optype;
int argflags;
- optype = POPi;
- pid = TOPi;
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
result = wait4pid(pid, &argflags, optype);
else {
PP(pp_system)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ dVAR; dSP; dMARK; dORIGMARK; dTARGET;
I32 value;
int result;
if (errno != EAGAIN) {
value = -1;
SP = ORIGMARK;
- PUSHi(value);
+ XPUSHi(value);
if (did_pipes) {
PerlLIO_close(pp[0]);
PerlLIO_close(pp[1]);
STATUS_NATIVE_CHILD_SET(-1);
}
}
- PUSHi(STATUS_CURRENT);
+ XPUSHi(STATUS_CURRENT);
RETURN;
}
if (did_pipes) {
#endif
}
if (PL_op->op_flags & OPf_STACKED) {
- SV *really = *++MARK;
+ SV * const really = *++MARK;
value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
}
else if (SP - MARK != 1)
- value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
+ value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
else {
value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
}
PL_statusvalue = 0;
result = 0;
if (PL_op->op_flags & OPf_STACKED) {
- SV *really = *++MARK;
+ SV * const really = *++MARK;
# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
value = (I32)do_aspawn(really, MARK, SP);
# else
}
else if (SP - MARK != 1) {
# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
- value = (I32)do_aspawn(Nullsv, MARK, SP);
+ value = (I32)do_aspawn(NULL, MARK, SP);
# else
- value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
+ value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
# endif
}
else {
STATUS_NATIVE_CHILD_SET(value);
do_execfree();
SP = ORIGMARK;
- PUSHi(result ? value : STATUS_CURRENT);
+ XPUSHi(result ? value : STATUS_CURRENT);
#endif /* !FORK or VMS */
RETURN;
}
PP(pp_exec)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ dVAR; dSP; dMARK; dORIGMARK; dTARGET;
I32 value;
if (PL_tainting) {
}
PERL_FLUSHALL_FOR_CHILD;
if (PL_op->op_flags & OPf_STACKED) {
- SV *really = *++MARK;
+ SV * const really = *++MARK;
value = (I32)do_aexec(really, MARK, SP);
}
else if (SP - MARK != 1)
#ifdef VMS
- value = (I32)vms_do_aexec(Nullsv, MARK, SP);
+ value = (I32)vms_do_aexec(NULL, MARK, SP);
#else
# ifdef __OPEN_VM
{
- (void ) do_aspawn(Nullsv, MARK, SP);
+ (void ) do_aspawn(NULL, MARK, SP);
value = 0;
}
# else
- value = (I32)do_aexec(Nullsv, MARK, SP);
+ value = (I32)do_aexec(NULL, MARK, SP);
# endif
#endif
else {
}
SP = ORIGMARK;
- PUSHi(value);
+ XPUSHi(value);
RETURN;
}
PP(pp_getppid)
{
#ifdef HAS_GETPPID
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
# ifdef THREADS_HAVE_PIDS
if (PL_ppid != 1 && getppid() == 1)
/* maybe the parent process has died. Refresh ppid cache */
PP(pp_getpgrp)
{
#ifdef HAS_GETPGRP
- dSP; dTARGET;
- Pid_t pid;
+ dVAR; dSP; dTARGET;
Pid_t pgrp;
+ const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
- if (MAXARG < 1)
- pid = 0;
- else
- pid = SvIVx(POPs);
#ifdef BSD_GETPGRP
pgrp = (I32)BSD_GETPGRP(pid);
#else
PP(pp_setpgrp)
{
#ifdef HAS_SETPGRP
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
Pid_t pgrp;
Pid_t pid;
if (MAXARG < 2) {
PP(pp_getpriority)
{
#ifdef HAS_GETPRIORITY
- dSP; dTARGET;
- int who = POPi;
- int which = TOPi;
+ dVAR; dSP; dTARGET;
+ const int who = POPi;
+ const int which = TOPi;
SETi( getpriority(which, who) );
RETURN;
#else
PP(pp_setpriority)
{
#ifdef HAS_SETPRIORITY
- dSP; dTARGET;
- int niceval = POPi;
- int who = POPi;
- int which = TOPi;
+ dVAR; dSP; dTARGET;
+ const int niceval = POPi;
+ const int who = POPi;
+ const int which = TOPi;
TAINT_PROPER("setpriority");
SETi( setpriority(which, who, niceval) >= 0 );
RETURN;
PP(pp_time)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
#ifdef BIG_TIME
- XPUSHn( time(Null(Time_t*)) );
+ XPUSHn( time(NULL) );
#else
- XPUSHi( time(Null(Time_t*)) );
+ XPUSHi( time(NULL) );
#endif
RETURN;
}
PP(pp_tms)
{
#ifdef HAS_TIMES
+ dVAR;
dSP;
EXTEND(SP, 4);
#ifndef VMS
PP(pp_gmtime)
{
+ dVAR;
dSP;
Time_t when;
const struct tm *tmbuf;
PP(pp_alarm)
{
#ifdef HAS_ALARM
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
int anum;
anum = POPi;
anum = alarm((unsigned int)anum);
PP(pp_sleep)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
I32 duration;
Time_t lasttime;
Time_t when;
}
/* Shared memory. */
+/* Merged with some message passing. */
PP(pp_shmwrite)
{
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dSP; dMARK; dTARGET;
- I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
- SP = MARK;
- PUSHi(value);
- RETURN;
-#else
- return pp_semget();
-#endif
-}
-
-/* Message passing. */
+ dVAR; dSP; dMARK; dTARGET;
+ const int op_type = PL_op->op_type;
+ I32 value;
-PP(pp_msgsnd)
-{
-#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dSP; dMARK; dTARGET;
- I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
- SP = MARK;
- PUSHi(value);
- RETURN;
-#else
- return pp_semget();
-#endif
-}
+ switch (op_type) {
+ case OP_MSGSND:
+ value = (I32)(do_msgsnd(MARK, SP) >= 0);
+ break;
+ case OP_MSGRCV:
+ value = (I32)(do_msgrcv(MARK, SP) >= 0);
+ break;
+ case OP_SEMOP:
+ value = (I32)(do_semop(MARK, SP) >= 0);
+ break;
+ default:
+ value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
+ break;
+ }
-PP(pp_msgrcv)
-{
-#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dSP; dMARK; dTARGET;
- I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
SP = MARK;
PUSHi(value);
RETURN;
PP(pp_semget)
{
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dSP; dMARK; dTARGET;
- int anum = do_ipcget(PL_op->op_type, MARK, SP);
+ dVAR; dSP; dMARK; dTARGET;
+ const int anum = do_ipcget(PL_op->op_type, MARK, SP);
SP = MARK;
if (anum == -1)
RETPUSHUNDEF;
PP(pp_semctl)
{
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dSP; dMARK; dTARGET;
- int anum = do_ipcctl(PL_op->op_type, MARK, SP);
+ dVAR; dSP; dMARK; dTARGET;
+ const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
SP = MARK;
if (anum == -1)
RETSETUNDEF;
#endif
}
-PP(pp_semop)
+/* I can't const this further without getting warnings about the types of
+ various arrays passed in from structures. */
+static SV *
+S_space_join_names_mortal(pTHX_ char *const *array)
{
-#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dSP; dMARK; dTARGET;
- I32 value = (I32)(do_semop(MARK, SP) >= 0);
- SP = MARK;
- PUSHi(value);
- RETURN;
-#else
- return pp_semget();
-#endif
+ SV *target;
+
+ if (array && *array) {
+ target = sv_2mortal(newSVpvs(""));
+ while (1) {
+ sv_catpv(target, *array);
+ if (!*++array)
+ break;
+ sv_catpvs(target, " ");
+ }
+ } else {
+ target = sv_mortalcopy(&PL_sv_no);
+ }
+ return target;
}
/* Get system info. */
PP(pp_ghostent)
{
#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
- dSP;
+ dVAR; dSP;
I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
EXTEND(SP, 10);
if (which == OP_GHBYNAME) {
#ifdef HAS_GETHOSTBYNAME
- char* name = POPpbytex;
+ const char* const name = POPpbytex;
hent = PerlSock_gethostbyname(name);
#else
DIE(aTHX_ PL_no_sock_func, "gethostbyname");
}
else if (which == OP_GHBYADDR) {
#ifdef HAS_GETHOSTBYADDR
- int addrtype = POPi;
- SV *addrsv = POPs;
+ const int addrtype = POPi;
+ SV * const addrsv = POPs;
STRLEN addrlen;
Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
}
if (hent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, (char*)hent->h_name);
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- for (elem = hent->h_aliases; elem && *elem; elem++) {
- sv_catpv(sv, *elem);
- if (elem[1])
- sv_catpvn(sv, " ", 1);
- }
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setiv(sv, (IV)hent->h_addrtype);
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
+ PUSHs(S_space_join_names_mortal(aTHX_ hent->h_aliases));
+ PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
len = hent->h_length;
- sv_setiv(sv, (IV)len);
+ PUSHs(sv_2mortal(newSViv((IV)len)));
#ifdef h_addr
for (elem = hent->h_addr_list; elem && *elem; elem++) {
- XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpvn(sv, *elem, len);
+ XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
}
#else
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
if (hent->h_addr)
- sv_setpvn(sv, hent->h_addr, len);
+ PUSHs(newSVpvn(hent->h_addr, len));
+ else
+ PUSHs(sv_mortalcopy(&PL_sv_no));
#endif /* h_addr */
}
RETURN;
PP(pp_gnetent)
{
#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
- dSP;
+ dVAR; dSP;
I32 which = PL_op->op_type;
- register char **elem;
register SV *sv;
#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
struct netent *getnetbyaddr(Netdb_net_t, int);
if (which == OP_GNBYNAME){
#ifdef HAS_GETNETBYNAME
- char *name = POPpbytex;
+ const char * const name = POPpbytex;
nent = PerlSock_getnetbyname(name);
#else
DIE(aTHX_ PL_no_sock_func, "getnetbyname");
}
else if (which == OP_GNBYADDR) {
#ifdef HAS_GETNETBYADDR
- int addrtype = POPi;
- Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
+ const int addrtype = POPi;
+ const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
nent = PerlSock_getnetbyaddr(addr, addrtype);
#else
DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
}
if (nent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, nent->n_name);
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- for (elem = nent->n_aliases; elem && *elem; elem++) {
- sv_catpv(sv, *elem);
- if (elem[1])
- sv_catpvn(sv, " ", 1);
- }
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setiv(sv, (IV)nent->n_addrtype);
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setiv(sv, (IV)nent->n_net);
+ PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
+ PUSHs(S_space_join_names_mortal(aTHX_ nent->n_aliases));
+ PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
+ PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
}
RETURN;
PP(pp_gprotoent)
{
#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
- dSP;
+ dVAR; dSP;
I32 which = PL_op->op_type;
- register char **elem;
register SV *sv;
#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
struct protoent *getprotobyname(Netdb_name_t);
if (which == OP_GPBYNAME) {
#ifdef HAS_GETPROTOBYNAME
- char* name = POPpbytex;
+ const char* const name = POPpbytex;
pent = PerlSock_getprotobyname(name);
#else
DIE(aTHX_ PL_no_sock_func, "getprotobyname");
}
else if (which == OP_GPBYNUMBER) {
#ifdef HAS_GETPROTOBYNUMBER
- int number = POPi;
+ const int number = POPi;
pent = PerlSock_getprotobynumber(number);
#else
DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
}
if (pent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, pent->p_name);
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- for (elem = pent->p_aliases; elem && *elem; elem++) {
- sv_catpv(sv, *elem);
- if (elem[1])
- sv_catpvn(sv, " ", 1);
- }
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setiv(sv, (IV)pent->p_proto);
+ PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
+ PUSHs(S_space_join_names_mortal(aTHX_ pent->p_aliases));
+ PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
}
RETURN;
PP(pp_gservent)
{
#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
- dSP;
+ dVAR; dSP;
I32 which = PL_op->op_type;
- register char **elem;
register SV *sv;
#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
if (which == OP_GSBYNAME) {
#ifdef HAS_GETSERVBYNAME
- char *proto = POPpbytex;
- char *name = POPpbytex;
-
- if (proto && !*proto)
- proto = Nullch;
-
- sent = PerlSock_getservbyname(name, proto);
+ const char * const proto = POPpbytex;
+ const char * const name = POPpbytex;
+ sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
#else
DIE(aTHX_ PL_no_sock_func, "getservbyname");
#endif
}
else if (which == OP_GSBYPORT) {
#ifdef HAS_GETSERVBYPORT
- char *proto = POPpbytex;
+ const char * const proto = POPpbytex;
unsigned short port = (unsigned short)POPu;
-
- if (proto && !*proto)
- proto = Nullch;
-
#ifdef HAS_HTONS
port = PerlSock_htons(port);
#endif
- sent = PerlSock_getservbyport(port, proto);
+ sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
#else
DIE(aTHX_ PL_no_sock_func, "getservbyport");
#endif
}
if (sent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, sent->s_name);
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- for (elem = sent->s_aliases; elem && *elem; elem++) {
- sv_catpv(sv, *elem);
- if (elem[1])
- sv_catpvn(sv, " ", 1);
- }
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
+ PUSHs(S_space_join_names_mortal(aTHX_ sent->s_aliases));
#ifdef HAS_NTOHS
- sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
+ PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
#else
- sv_setiv(sv, (IV)(sent->s_port));
+ PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
#endif
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, sent->s_proto);
+ PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
}
RETURN;
PP(pp_shostent)
{
#ifdef HAS_SETHOSTENT
- dSP;
+ dVAR; dSP;
PerlSock_sethostent(TOPi);
RETSETYES;
#else
PP(pp_snetent)
{
#ifdef HAS_SETNETENT
- dSP;
+ dVAR; dSP;
PerlSock_setnetent(TOPi);
RETSETYES;
#else
PP(pp_sprotoent)
{
#ifdef HAS_SETPROTOENT
- dSP;
+ dVAR; dSP;
PerlSock_setprotoent(TOPi);
RETSETYES;
#else
PP(pp_sservent)
{
#ifdef HAS_SETSERVENT
- dSP;
+ dVAR; dSP;
PerlSock_setservent(TOPi);
RETSETYES;
#else
PP(pp_ehostent)
{
#ifdef HAS_ENDHOSTENT
- dSP;
+ dVAR; dSP;
PerlSock_endhostent();
EXTEND(SP,1);
RETPUSHYES;
PP(pp_enetent)
{
#ifdef HAS_ENDNETENT
- dSP;
+ dVAR; dSP;
PerlSock_endnetent();
EXTEND(SP,1);
RETPUSHYES;
PP(pp_eprotoent)
{
#ifdef HAS_ENDPROTOENT
- dSP;
+ dVAR; dSP;
PerlSock_endprotoent();
EXTEND(SP,1);
RETPUSHYES;
PP(pp_eservent)
{
#ifdef HAS_ENDSERVENT
- dSP;
+ dVAR; dSP;
PerlSock_endservent();
EXTEND(SP,1);
RETPUSHYES;
PP(pp_gpwent)
{
#ifdef HAS_PASSWD
- dSP;
+ dVAR; dSP;
I32 which = PL_op->op_type;
register SV *sv;
struct passwd *pwent = NULL;
switch (which) {
case OP_GPWNAM:
{
- char* name = POPpbytex;
+ const char* const name = POPpbytex;
pwent = getpwnam(name);
}
break;
}
if (pwent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, pwent->pw_name);
+ PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- SvPOK_off(sv);
+ PUSHs(sv = sv_2mortal(newSViv(0)));
/* If we have getspnam(), we try to dig up the shadow
* password. If we are underprivileged, the shadow
* interface will set the errno to EACCES or similar,
* has a different API than the Solaris/IRIX one. */
# if defined(HAS_GETSPNAM) && !defined(_AIX)
{
- struct spwd *spwent;
- int saverrno; /* Save and restore errno so that
+ const int saverrno = errno;
+ const struct spwd * const spwent = getspnam(pwent->pw_name);
+ /* Save and restore errno so that
* underprivileged attempts seem
* to have never made the unsccessful
* attempt to retrieve the shadow password. */
-
- saverrno = errno;
- spwent = getspnam(pwent->pw_name);
errno = saverrno;
if (spwent && spwent->sp_pwdp)
sv_setpv(sv, spwent->sp_pwdp);
SvTAINTED_on(sv);
# endif
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
# if Uid_t_sign <= 0
- sv_setiv(sv, (IV)pwent->pw_uid);
+ PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
# else
- sv_setuv(sv, (UV)pwent->pw_uid);
+ PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
# endif
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
# if Uid_t_sign <= 0
- sv_setiv(sv, (IV)pwent->pw_gid);
+ PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
# else
- sv_setuv(sv, (UV)pwent->pw_gid);
+ PUSHs(sv_2mortal(newSVuv((UV)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.
* A better interface would have been to return a hash,
* but we are accursed by our history, alas. --jhi. */
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
# ifdef PWCHANGE
- sv_setiv(sv, (IV)pwent->pw_change);
+ PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
# else
# ifdef PWQUOTA
- sv_setiv(sv, (IV)pwent->pw_quota);
+ PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
# else
# ifdef PWAGE
- sv_setpv(sv, pwent->pw_age);
+ PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
+# else
+ /* I think that you can never get this compiled, but just in case. */
+ PUSHs(sv_mortalcopy(&PL_sv_no));
# endif
# endif
# endif
/* pw_class and pw_comment are mutually exclusive--.
* see the above note for pw_change, pw_quota, and pw_age. */
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
# ifdef PWCLASS
- sv_setpv(sv, pwent->pw_class);
+ PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
# else
# ifdef PWCOMMENT
- sv_setpv(sv, pwent->pw_comment);
+ PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
+# else
+ /* I think that you can never get this compiled, but just in case. */
+ PUSHs(sv_mortalcopy(&PL_sv_no));
# endif
# endif
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
# ifdef PWGECOS
- sv_setpv(sv, pwent->pw_gecos);
+ PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
+# else
+ PUSHs(sv_mortalcopy(&PL_sv_no));
# endif
# ifndef INCOMPLETE_TAINTS
/* pw_gecos is tainted because user himself can diddle with it. */
SvTAINTED_on(sv);
# endif
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, pwent->pw_dir);
+ PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, pwent->pw_shell);
+ PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
# ifndef INCOMPLETE_TAINTS
/* pw_shell is tainted because user himself can diddle with it. */
SvTAINTED_on(sv);
# endif
# ifdef PWEXPIRE
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setiv(sv, (IV)pwent->pw_expire);
+ PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
# endif
}
RETURN;
PP(pp_spwent)
{
#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
- dSP;
+ dVAR; dSP;
setpwent();
RETPUSHYES;
#else
PP(pp_epwent)
{
#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
- dSP;
+ dVAR; dSP;
endpwent();
RETPUSHYES;
#else
PP(pp_ggrent)
{
#ifdef HAS_GROUP
- dSP;
- I32 which = PL_op->op_type;
- register char **elem;
- register SV *sv;
- struct group *grent;
+ dVAR; dSP;
+ const I32 which = PL_op->op_type;
+ const struct group *grent;
if (which == OP_GGRNAM) {
- char* name = POPpbytex;
- grent = (struct group *)getgrnam(name);
+ const char* const name = POPpbytex;
+ grent = (const struct group *)getgrnam(name);
}
else if (which == OP_GGRGID) {
- Gid_t gid = POPi;
- grent = (struct group *)getgrgid(gid);
+ const Gid_t gid = POPi;
+ grent = (const struct group *)getgrgid(gid);
}
else
#ifdef HAS_GETGRENT
EXTEND(SP, 4);
if (GIMME != G_ARRAY) {
- PUSHs(sv = sv_newmortal());
+ SV * const sv = sv_newmortal();
+
+ PUSHs(sv);
if (grent) {
if (which == OP_GGRNAM)
sv_setiv(sv, (IV)grent->gr_gid);
}
if (grent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, grent->gr_name);
+ PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
#ifdef GRPASSWD
- sv_setpv(sv, grent->gr_passwd);
+ PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
+#else
+ PUSHs(sv_mortalcopy(&PL_sv_no));
#endif
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setiv(sv, (IV)grent->gr_gid);
+ PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
/* In UNICOS/mk (_CRAYMPP) the multithreading
* versions (getgrnam_r, getgrgid_r)
* seem to return an illegal pointer
* but the gr_mem is poisonous anyway.
* So yes, you cannot get the list of group
* members if building multithreaded in UNICOS/mk. */
- for (elem = grent->gr_mem; elem && *elem; elem++) {
- sv_catpv(sv, *elem);
- if (elem[1])
- sv_catpvn(sv, " ", 1);
- }
+ PUSHs(S_space_join_names_mortal(aTHX_ grent->gr_mem));
#endif
}
PP(pp_sgrent)
{
#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
- dSP;
+ dVAR; dSP;
setgrent();
RETPUSHYES;
#else
PP(pp_egrent)
{
#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
- dSP;
+ dVAR; dSP;
endgrent();
RETPUSHYES;
#else
PP(pp_getlogin)
{
#ifdef HAS_GETLOGIN
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
char *tmps;
EXTEND(SP, 1);
if (!(tmps = PerlProc_getlogin()))
PP(pp_syscall)
{
#ifdef HAS_SYSCALL
- dSP; dMARK; dORIGMARK; dTARGET;
+ dVAR; dSP; dMARK; dORIGMARK; dTARGET;
register I32 items = SP - MARK;
unsigned long a[20];
register I32 i = 0;
lockf_emulate_flock(int fd, int operation)
{
int i;
- int save_errno;
+ const int save_errno = errno;
Off_t pos;
/* flock locks entire file so for lockf we need to do the same */
- save_errno = errno;
pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
if (pos > 0) /* is seekable and needs to be repositioned */
if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
https://perl5.git.perl.org / perl5.git / blobdiff