/* pp_sys.c
*
- * Copyright (C) 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+ * 2004, 2005, 2006, 2007 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.
return res;
}
-# define PERL_EFF_ACCESS(p,f) (emulate_eaccess((p), (f)))
-#endif
-
-#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)
-{
- PERL_UNUSED_ARG(path);
- PERL_UNUSED_ARG(mode);
- Perl_croak(aTHX_ "switching effective uid is not implemented");
- /*NOTREACHED*/
- return -1;
-}
+# define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
#endif
PP(pp_backtick)
mode = "rt";
fp = PerlProc_popen(tmps, mode);
if (fp) {
- const char * const type = PL_curcop->cop_io ? SvPV_nolen_const(PL_curcop->cop_io) : NULL;
+ const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
if (type && *type)
PerlIO_apply_layers(aTHX_ fp,mode,type);
if (gimme == G_VOID) {
char tmpbuf[256];
while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
- ;
+ NOOP;
}
else if (gimme == G_SCALAR) {
ENTER;
PL_rs = &PL_sv_undef;
sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
- ;
+ NOOP;
LEAVE;
XPUSHs(TARG);
SvTAINTED_on(TARG);
SvREFCNT_dec(sv);
break;
}
- XPUSHs(sv_2mortal(sv));
+ mXPUSHs(sv);
if (SvLEN(sv) - SvCUR(sv) > 20) {
SvPV_shrink_to_cur(sv);
}
PL_last_in_gv = (GV*)*PL_stack_sp--;
SAVESPTR(PL_rs); /* This is not permanent, either. */
- PL_rs = sv_2mortal(newSVpvs("\000"));
+ PL_rs = newSVpvs_flags("\000", SVs_TEMP);
#ifndef DOSISH
#ifndef CSH
*SvPVX(PL_rs) = '\n';
else if (SP == MARK) {
tmpsv = &PL_sv_no;
EXTEND(SP, 1);
+ SP = MARK + 1;
}
else {
tmpsv = TOPs;
tmps = SvPV_const(tmpsv, len);
}
if (!tmps || !len)
- tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
+ tmpsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
- Perl_warn(aTHX_ "%"SVf, tmpsv);
+ Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
RETSETYES;
}
}
else {
tmpsv = TOPs;
- tmps = SvROK(tmpsv) ? NULL : SvPV_const(tmpsv, len);
+ tmps = SvROK(tmpsv) ? (const char *)NULL : SvPV_const(tmpsv, len);
}
if (!tmps || !len) {
SV * const error = ERRSV;
}
}
if (!tmps || !len)
- tmpsv = sv_2mortal(newSVpvs("Died"));
+ tmpsv = newSVpvs_flags("Died", SVs_TEMP);
- DIE(aTHX_ "%"SVf, tmpsv);
+ DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
}
/* I/O. */
if (!isGV(gv))
DIE(aTHX_ PL_no_usym, "filehandle");
- if ((io = GvIOp(gv)))
+
+ if ((io = GvIOp(gv))) {
+ MAGIC *mg;
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
- if (io) {
- MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ if (IoDIRP(io) && ckWARN2(WARN_IO, WARN_DEPRECATED))
+ Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
+ "Opening dirhandle %s also as a file", GvENAME(gv));
+
+ mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
if (mg) {
/* Method's args are same as ours ... */
/* ... except handle is replaced by the object */
PP(pp_close)
{
dVAR; dSP;
- IO *io;
- MAGIC *mg;
GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs;
- 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("CLOSE", G_SCALAR);
- LEAVE;
- SPAGAIN;
- RETURN;
+ if (gv) {
+ IO * const io = GvIO(gv);
+ if (io) {
+ MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ if (mg) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ PUTBACK;
+ ENTER;
+ call_method("CLOSE", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+ }
}
EXTEND(SP, 1);
PUSHs(boolSV(do_close(gv, TRUE)));
IoTYPE(wstio) = IoTYPE_WRONLY;
if (!IoIFP(rstio) || !IoOFP(wstio)) {
- if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
- else PerlLIO_close(fd[0]);
- if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
- else PerlLIO_close(fd[1]);
+ if (IoIFP(rstio))
+ PerlIO_close(IoIFP(rstio));
+ else
+ PerlLIO_close(fd[0]);
+ if (IoOFP(wstio))
+ PerlIO_close(IoOFP(wstio));
+ else
+ PerlLIO_close(fd[1]);
goto badexit;
}
#if defined(HAS_FCNTL) && defined(F_SETFD)
Mode_t anum;
if (MAXARG < 1) {
- anum = PerlLIO_umask(0);
- (void)PerlLIO_umask(anum);
+ 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
+ * that another thread could create world-writeable files. */
+ if (anum != 022)
+ (void)PerlLIO_umask(anum);
}
else
anum = PerlLIO_umask(POPi);
GV *gv;
IO *io;
PerlIO *fp;
- MAGIC *mg;
SV *discp = NULL;
if (MAXARG < 1)
gv = (GV*)POPs;
- if (gv && (io = GvIO(gv))
- && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
- {
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)io, mg));
- if (discp)
- XPUSHs(discp);
- PUTBACK;
- ENTER;
- call_method("BINMODE", G_SCALAR);
- LEAVE;
- SPAGAIN;
- RETURN;
+ if (gv && (io = GvIO(gv))) {
+ MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ if (mg) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ if (discp)
+ XPUSHs(discp);
+ PUTBACK;
+ ENTER;
+ call_method("BINMODE", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
}
EXTEND(SP, 1);
}
PUTBACK;
- if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
- (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) : NULL)) {
- SPAGAIN;
- RETPUSHUNDEF;
- }
+ {
+ STRLEN len = 0;
+ const char *d = NULL;
+ int mode;
+ if (discp)
+ d = SvPV_const(discp, len);
+ mode = mode_from_discipline(d, len);
+ if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
+ if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
+ if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
+ SPAGAIN;
+ RETPUSHUNDEF;
+ }
+ }
+ SPAGAIN;
+ RETPUSHYES;
+ }
+ else {
+ SPAGAIN;
+ RETPUSHUNDEF;
}
- SPAGAIN;
- RETPUSHYES;
- }
- else {
- SPAGAIN;
- RETPUSHUNDEF;
}
}
break;
}
items = SP - MARK++;
- if (sv_isobject(*MARK)) {
+ if (sv_isobject(*MARK)) { /* Calls GET magic. */
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
/* Not clear why we don't call call_method here too.
* perhaps to get different error message ?
*/
- stash = gv_stashsv(*MARK, FALSE);
+ STRLEN len;
+ const char *name = SvPV_nomg_const(*MARK, len);
+ stash = gv_stashpvn(name, len, 0);
if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
- methname, *MARK);
+ methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
}
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
if (gv && isGV(gv) && (cv = GvCV(gv))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
- XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
+ mXPUSHi(SvREFCNT(obj) - 1);
PUTBACK;
ENTER;
call_sv((SV *)cv, G_VOID);
GV *gv;
HV * const hv = (HV*)POPs;
- SV * const sv = sv_mortalcopy(&PL_sv_no);
-
- sv_setpv(sv, "AnyDBM_File");
- stash = gv_stashsv(sv, FALSE);
+ SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
+ stash = gv_stashsv(sv, 0);
if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
PUTBACK;
require_pv("AnyDBM_File.pm");
SPAGAIN;
- if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
+ if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
DIE(aTHX_ "No dbm on this machine");
}
PUSHs(sv);
PUSHs(left);
if (SvIV(right))
- PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
+ mPUSHu(O_RDWR|O_CREAT);
else
- PUSHs(sv_2mortal(newSVuv(O_RDWR)));
+ mPUSHu(O_RDWR);
PUSHs(right);
PUTBACK;
call_sv((SV*)GvCV(gv), G_SCALAR);
PUSHMARK(SP);
PUSHs(sv);
PUSHs(left);
- PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
+ mPUSHu(O_RDONLY);
PUSHs(right);
PUTBACK;
call_sv((SV*)GvCV(gv), G_SCALAR);
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);
+ mPUSHn(value);
}
RETURN;
#else
{
dVAR; dSP; dTARGET;
HV *hv;
- GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
+ GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
GV * egv = GvEGV(PL_defoutgv);
if (!egv)
XPUSHTARG;
}
else {
- XPUSHs(sv_2mortal(newRV((SV*)egv)));
+ mXPUSHs(newRV((SV*)egv));
}
}
{
dVAR; dSP; dTARGET;
IO *io = NULL;
- MAGIC *mg;
GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
- if (gv && (io = GvIO(gv))
- && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
- {
- const I32 gimme = GIMME_V;
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)io, mg));
- PUTBACK;
- ENTER;
- call_method("GETC", gimme);
- LEAVE;
- SPAGAIN;
- if (gimme == G_SCALAR)
- SvSetMagicSV_nosteal(TARG, TOPs);
- RETURN;
+ if (gv && (io = GvIO(gv))) {
+ MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ if (mg) {
+ const I32 gimme = GIMME_V;
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ PUTBACK;
+ ENTER;
+ call_method("GETC", gimme);
+ LEAVE;
+ SPAGAIN;
+ if (gimme == G_SCALAR)
+ SvSetMagicSV_nosteal(TARG, TOPs);
+ RETURN;
+ }
}
if (!gv || do_eof(gv)) { /* make sure we have fp with something */
if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
register PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
+ PERL_ARGS_ASSERT_DOFORM;
+
ENTER;
SAVETMPS;
PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
- PUSHFORMAT(cx);
- cx->blk_sub.retop = retop;
+ PUSHFORMAT(cx, retop);
SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
register IO *io;
GV *fgv;
CV *cv;
+ SV * tmpsv = NULL;
if (MAXARG == 0)
gv = PL_defoutgv;
else
fgv = gv;
+ if (!fgv)
+ goto not_a_format_reference;
+
cv = GvFORM(fgv);
if (!cv) {
- if (fgv) {
- SV * const tmpsv = sv_newmortal();
- const char *name;
- gv_efullname4(tmpsv, fgv, NULL, FALSE);
- name = SvPV_nolen_const(tmpsv);
- if (name && *name)
- DIE(aTHX_ "Undefined format \"%s\" called", name);
- }
+ const char *name;
+ tmpsv = sv_newmortal();
+ gv_efullname4(tmpsv, fgv, NULL, FALSE);
+ name = SvPV_nolen_const(tmpsv);
+ if (name && *name)
+ DIE(aTHX_ "Undefined format \"%s\" called", name);
+
+ not_a_format_reference:
DIE(aTHX_ "Not a format reference");
}
if (CvCLONE(cv))
PP(pp_leavewrite)
{
dVAR; dSP;
- GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
+ GV * const gv = cxstack[cxstack_ix].blk_format.gv;
register IO * const io = GvIOp(gv);
- PerlIO * const ofp = IoOFP(io);
+ PerlIO *ofp;
PerlIO *fp;
SV **newsp;
I32 gimme;
register PERL_CONTEXT *cx;
+ if (!io || !(ofp = IoOFP(io)))
+ goto forget_top;
+
DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
(long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
- if (!io || !ofp)
- goto forget_top;
+
if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
PL_formtarget != PL_toptarget)
{
gv_efullname4(sv, fgv, NULL, FALSE);
name = SvPV_nolen_const(sv);
if (name && *name)
- DIE(aTHX_ "Undefined top format \"%s\" called",name);
+ DIE(aTHX_ "Undefined top format \"%s\" called", name);
+ else
+ DIE(aTHX_ "Undefined top format called");
}
- /* why no:
- else
- DIE(aTHX_ "Undefined top format called");
- ?*/
- if (CvCLONE(cv))
+ if (cv && CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
- return doform(cv,gv,PL_op);
+ return doform(cv, gv, PL_op);
}
forget_top:
IO *io;
PerlIO *fp;
SV *sv;
- MAGIC *mg;
GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
- if (gv && (io = GvIO(gv))
- && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
- {
- if (MARK == ORIGMARK) {
- MEXTEND(SP, 1);
- ++MARK;
- Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
- ++SP;
+ if (gv && (io = GvIO(gv))) {
+ MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ if (mg) {
+ if (MARK == ORIGMARK) {
+ MEXTEND(SP, 1);
+ ++MARK;
+ Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
+ ++SP;
+ }
+ PUSHMARK(MARK - 1);
+ *MARK = SvTIED_obj((SV*)io, mg);
+ PUTBACK;
+ ENTER;
+ call_method("PRINTF", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ MARK = ORIGMARK + 1;
+ *MARK = *SP;
+ SP = MARK;
+ RETURN;
}
- PUSHMARK(MARK - 1);
- *MARK = SvTIED_obj((SV*)io, mg);
- PUTBACK;
- ENTER;
- call_method("PRINTF", G_SCALAR);
- LEAVE;
- SPAGAIN;
- MARK = ORIGMARK + 1;
- *MARK = *SP;
- SP = MARK;
- RETURN;
}
sv = newSV(0);
goto just_say_no;
}
else {
+ if (SvTAINTED(MARK[1]))
+ TAINT_PROPER("printf");
do_sprintf(sv, SP - MARK, MARK + 1);
if (!do_print(sv, fp))
goto just_say_no;
buffer = SvGROW(bufsv, (STRLEN)(length+1));
/* 'offset' means 'flags' here */
count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
- (struct sockaddr *)namebuf, &bufsize);
+ (struct sockaddr *)namebuf, &bufsize);
if (count < 0)
RETPUSHUNDEF;
#ifdef EPOC
IO *io;
SV *bufsv;
const char *buffer;
- Size_t length = 0;
SSize_t retval;
STRLEN blen;
- MAGIC *mg;
+ STRLEN orig_blen_bytes;
const int op_type = PL_op->op_type;
+ bool doing_utf8;
+ U8 *tmpbuf = NULL;
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;
+ && gv && (io = GvIO(gv))) {
+ MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ if (mg) {
+ SV *sv;
- if (MARK == SP - 1) {
- EXTEND(SP, 1000);
- sv = sv_2mortal(newSViv(sv_len(*SP)));
+ if (MARK == SP - 1) {
+ EXTEND(SP, 1000);
+ sv = sv_2mortal(newSViv(sv_len(*SP)));
+ PUSHs(sv);
+ PUTBACK;
+ }
+
+ PUSHMARK(ORIGMARK);
+ *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
+ ENTER;
+ call_method("WRITE", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ sv = POPs;
+ SP = ORIGMARK;
PUSHs(sv);
- PUTBACK;
+ RETURN;
}
-
- PUSHMARK(ORIGMARK);
- *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
- ENTER;
- call_method("WRITE", G_SCALAR);
- LEAVE;
- SPAGAIN;
- sv = POPs;
- SP = ORIGMARK;
- PUSHs(sv);
- RETURN;
}
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);
-#else
- length = (Size_t)SvIVx(*++MARK);
-#endif
- if ((SSize_t)length < 0)
- DIE(aTHX_ "Negative length");
- }
- }
SETERRNO(0,0);
io = GvIO(gv);
- if (!io || !IoIFP(io)) {
+ if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
retval = -1;
- if (ckWARN(WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
+ 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);
+ }
SETERRNO(EBADF,RMS_IFI);
goto say_undef;
}
+ /* Do this first to trigger any overloading. */
+ buffer = SvPV_const(bufsv, blen);
+ orig_blen_bytes = blen;
+ doing_utf8 = DO_UTF8(bufsv);
+
if (PerlIO_isutf8(IoIFP(io))) {
if (!SvUTF8(bufsv)) {
- bufsv = sv_2mortal(newSVsv(bufsv));
- buffer = sv_2pvutf8(bufsv, &blen);
- } else
- buffer = SvPV_const(bufsv, blen);
+ /* We don't modify the original scalar. */
+ tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
+ buffer = (char *) tmpbuf;
+ doing_utf8 = TRUE;
+ }
}
- else {
- if (DO_UTF8(bufsv)) {
- /* Not modifying source SV, so making a temporary copy. */
- bufsv = sv_2mortal(newSVsv(bufsv));
- sv_utf8_downgrade(bufsv, FALSE);
- }
- buffer = SvPV_const(bufsv, blen);
+ else if (doing_utf8) {
+ STRLEN tmplen = blen;
+ U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
+ if (!doing_utf8) {
+ tmpbuf = result;
+ buffer = (char *) tmpbuf;
+ blen = tmplen;
+ }
+ else {
+ assert((char *)result == buffer);
+ Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
+ }
}
if (op_type == OP_SYSWRITE) {
+ Size_t length = 0; /* This length is in characters. */
+ STRLEN blen_chars;
IV offset;
- if (DO_UTF8(bufsv)) {
- /* length and offset are in chars */
- blen = sv_len_utf8(bufsv);
+
+ if (doing_utf8) {
+ if (tmpbuf) {
+ /* The SV is bytes, and we've had to upgrade it. */
+ blen_chars = orig_blen_bytes;
+ } else {
+ /* The SV really is UTF-8. */
+ if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
+ /* Don't call sv_len_utf8 again because it will call magic
+ or overloading a second time, and we might get back a
+ different result. */
+ blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
+ } else {
+ /* It's safe, and it may well be cached. */
+ blen_chars = sv_len_utf8(bufsv);
+ }
+ }
+ } else {
+ blen_chars = blen;
+ }
+
+ if (MARK >= SP) {
+ length = blen_chars;
+ } else {
+#if Size_t_size > IVSIZE
+ length = (Size_t)SvNVx(*++MARK);
+#else
+ length = (Size_t)SvIVx(*++MARK);
+#endif
+ if ((SSize_t)length < 0) {
+ Safefree(tmpbuf);
+ DIE(aTHX_ "Negative length");
+ }
}
+
if (MARK < SP) {
offset = SvIVx(*++MARK);
if (offset < 0) {
- if (-offset > (IV)blen)
+ if (-offset > (IV)blen_chars) {
+ Safefree(tmpbuf);
DIE(aTHX_ "Offset outside string");
- offset += blen;
- } else if (offset >= (IV)blen && blen > 0)
+ }
+ offset += blen_chars;
+ } else if (offset >= (IV)blen_chars && blen_chars > 0) {
+ Safefree(tmpbuf);
DIE(aTHX_ "Offset outside string");
+ }
} else
offset = 0;
- if (length > blen - offset)
- length = blen - offset;
- if (DO_UTF8(bufsv)) {
- buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
- length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
+ if (length > blen_chars - offset)
+ length = blen_chars - offset;
+ if (doing_utf8) {
+ /* Here we convert length from characters to bytes. */
+ if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
+ /* Either we had to convert the SV, or the SV is magical, or
+ the SV has overloading, in which case we can't or mustn't
+ or mustn't call it again. */
+
+ buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
+ length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
+ } else {
+ /* It's a real UTF-8 SV, and it's not going to change under
+ us. Take advantage of any cache. */
+ I32 start = offset;
+ I32 len_I32 = length;
+
+ /* Convert the start and end character positions to bytes.
+ Remember that the second argument to sv_pos_u2b is relative
+ to the first. */
+ sv_pos_u2b(bufsv, &start, &len_I32);
+
+ buffer += start;
+ length = len_I32;
+ }
}
else {
buffer = buffer+offset;
else
DIE(aTHX_ PL_no_sock_func, "send");
#endif
+
if (retval < 0)
goto say_undef;
SP = ORIGMARK;
- if (DO_UTF8(bufsv))
+ if (doing_utf8)
retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
+
+ Safefree(tmpbuf);
#if Size_t_size > IVSIZE
PUSHn(retval);
#else
RETURN;
say_undef:
+ Safefree(tmpbuf);
SP = ORIGMARK;
RETPUSHUNDEF;
}
IoLINES(io) = 0;
IoFLAGS(io) &= ~IOf_START;
do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
- sv_setpvn(GvSV(gv), "-", 1);
+ if ( GvSV(gv) ) {
+ sv_setpvn(GvSV(gv), "-", 1);
+ }
+ else {
+ GvSV(gv) = newSVpvn("-", 1);
+ }
SvSETMAGIC(GvSV(gv));
}
else if (!nextargv(gv))
dVAR; dSP; dTARGET;
GV *gv;
IO *io;
- MAGIC *mg;
if (MAXARG != 0)
PL_last_in_gv = (GV*)POPs;
gv = PL_last_in_gv;
- 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("TELL", G_SCALAR);
- LEAVE;
- SPAGAIN;
- RETURN;
+ if (gv && (io = GvIO(gv))) {
+ MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ if (mg) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ PUTBACK;
+ ENTER;
+ call_method("TELL", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
}
#if LSEEKSIZE > IVSIZE
PP(pp_sysseek)
{
dVAR; dSP;
- IO *io;
const int whence = POPi;
#if LSEEKSIZE > IVSIZE
const Off_t offset = (Off_t)SvNVx(POPs);
#else
const Off_t offset = (Off_t)SvIVx(POPs);
#endif
- MAGIC *mg;
GV * const gv = PL_last_in_gv = (GV*)POPs;
+ IO *io;
- if (gv && (io = GvIO(gv))
- && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
- {
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)io, mg));
+ if (gv && (io = GvIO(gv))) {
+ MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ if (mg) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
#if LSEEKSIZE > IVSIZE
- XPUSHs(sv_2mortal(newSVnv((NV) offset)));
+ mXPUSHn((NV) offset);
#else
- XPUSHs(sv_2mortal(newSViv(offset)));
+ mXPUSHi(offset);
#endif
- XPUSHs(sv_2mortal(newSViv(whence)));
- PUTBACK;
- ENTER;
- call_method("SEEK", G_SCALAR);
- LEAVE;
- SPAGAIN;
- RETURN;
+ mXPUSHi(whence);
+ PUTBACK;
+ ENTER;
+ call_method("SEEK", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
}
if (PL_op->op_type == OP_SEEK)
newSViv(sought)
#endif
: newSVpvn(zero_but_true, ZBTLEN);
- PUSHs(sv_2mortal(sv));
+ mPUSHs(sv);
}
}
RETURN;
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;
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;
}
GV * const gv = (GV*)POPs;
register IO * const io = GvIOn(gv);
STRLEN len;
- int bind_ok = 0;
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)
- bind_ok = 1;
-
-
- if (bind_ok)
+ if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
RETPUSHYES;
else
RETPUSHUNDEF;
nstio = GvIOn(ngv);
fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
+#if defined(OEMVS)
+ if (len == 0) {
+ /* Some platforms indicate zero length when an AF_UNIX client is
+ * not bound. Simulate a non-zero-length sockaddr structure in
+ * this case. */
+ namebuf[0] = 0; /* sun_len */
+ namebuf[1] = AF_UNIX; /* sun_family */
+ len = 2;
+ }
+#endif
+
if (fd < 0)
goto badexit;
if (IoIFP(nstio))
{
dVAR;
dSP;
- GV *gv;
+ GV *gv = NULL;
+ IO *io;
I32 gimme;
I32 max = 13;
do_fstat_warning_check:
if (ckWARN(WARN_IO))
Perl_warner(aTHX_ packWARN(WARN_IO),
- "lstat() on filehandle %s", GvENAME(gv));
+ "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
} else if (PL_laststype != OP_LSTAT)
Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
}
PL_laststype = OP_STAT;
PL_statgv = gv;
sv_setpvn(PL_statname, "", 0);
- PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
- ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
- }
+ if(gv) {
+ io = GvIO(gv);
+ do_fstat_have_io:
+ if (io) {
+ if (IoIFP(io)) {
+ PL_laststatval =
+ PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
+ } else if (IoDIRP(io)) {
+ PL_laststatval =
+ PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
+ } else {
+ PL_laststatval = -1;
+ }
+ }
+ }
+ }
+
if (PL_laststatval < 0) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, GvIO(gv), PL_op->op_type);
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)
- goto do_fstat_warning_check;
- goto do_fstat;
- }
+ } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+ gv = (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) {
+ io = (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));
PL_statgv = NULL;
PL_laststype = PL_op->op_type;
if (max) {
EXTEND(SP, max);
EXTEND_MORTAL(max);
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
- PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
- PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
+ mPUSHi(PL_statcache.st_dev);
+ mPUSHi(PL_statcache.st_ino);
+ mPUSHu(PL_statcache.st_mode);
+ mPUSHu(PL_statcache.st_nlink);
#if Uid_t_size > IVSIZE
- PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
+ mPUSHn(PL_statcache.st_uid);
#else
# if Uid_t_sign <= 0
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
+ mPUSHi(PL_statcache.st_uid);
# else
- PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
+ mPUSHu(PL_statcache.st_uid);
# endif
#endif
#if Gid_t_size > IVSIZE
- PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
+ mPUSHn(PL_statcache.st_gid);
#else
# if Gid_t_sign <= 0
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
+ mPUSHi(PL_statcache.st_gid);
# else
- PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
+ mPUSHu(PL_statcache.st_gid);
# endif
#endif
#ifdef USE_STAT_RDEV
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
+ mPUSHi(PL_statcache.st_rdev);
#else
- PUSHs(sv_2mortal(newSVpvs("")));
+ PUSHs(newSVpvs_flags("", SVs_TEMP));
#endif
#if Off_t_size > IVSIZE
- PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
+ mPUSHn(PL_statcache.st_size);
#else
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
+ mPUSHi(PL_statcache.st_size);
#endif
#ifdef BIG_TIME
- PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
- PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
- PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
+ mPUSHn(PL_statcache.st_atime);
+ mPUSHn(PL_statcache.st_mtime);
+ mPUSHn(PL_statcache.st_ctime);
#else
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
+ mPUSHi(PL_statcache.st_atime);
+ mPUSHi(PL_statcache.st_mtime);
+ mPUSHi(PL_statcache.st_ctime);
#endif
#ifdef USE_STAT_BLOCKS
- PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
- PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
+ mPUSHu(PL_statcache.st_blksize);
+ mPUSHu(PL_statcache.st_blocks);
#else
- PUSHs(sv_2mortal(newSVpvs("")));
- PUSHs(sv_2mortal(newSVpvs("")));
+ PUSHs(newSVpvs_flags("", SVs_TEMP));
+ PUSHs(newSVpvs_flags("", SVs_TEMP));
#endif
}
RETURN;
effective = TRUE;
break;
-
case OP_FTEEXEC:
#ifdef PERL_EFF_ACCESS
- access_mode = W_OK;
+ access_mode = X_OK;
#else
use_access = 0;
#endif
if (use_access) {
#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
- const char *const name = POPpx;
+ const char *name = POPpx;
if (effective) {
# ifdef PERL_EFF_ACCESS
result = PERL_EFF_ACCESS(name, access_mode);
#if defined(DOSISH) || defined(USEMYBINMODE)
/* ignore trailing ^Z on short files */
- if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
+ if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
--len;
#endif
gv = (GV*)SvRV(sv);
}
else {
- tmps = SvPVx_nolen_const(sv);
+ tmps = SvPV_nolen_const(sv);
}
}
#ifdef HAS_FCHDIR
IO* const io = GvIO(gv);
if (io) {
- if (IoIFP(io)) {
- PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
- }
- else if (IoDIRP(io)) {
-#ifdef HAS_DIRFD
- PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
-#else
- DIE(aTHX_ PL_no_func, "dirfd");
-#endif
+ if (IoDIRP(io)) {
+ PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
+ } else if (IoIFP(io)) {
+ PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
}
else {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
char *s;
PerlIO *myfp;
int anum = 1;
+ Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
+
+ PERL_ARGS_ASSERT_DOONELINER;
- Newx(cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
- strcpy(cmdline, cmd);
- strcat(cmdline, " ");
+ Newx(cmdline, size, char);
+ my_strlcpy(cmdline, cmd, size);
+ my_strlcat(cmdline, " ", size);
for (s = cmdline + strlen(cmdline); *filename; ) {
*s++ = '\\';
*s++ = *filename++;
}
- strcpy(s, " 2>&1");
+ if (s - cmdline < size)
+ my_strlcpy(s, " 2>&1", size - (s - cmdline));
myfp = PerlProc_popen(cmdline, "r");
Safefree(cmdline);
if (!io)
goto nope;
+ if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
+ Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
+ "Opening filehandle %s also as a directory", GvENAME(gv));
if (IoDIRP(io))
PerlDir_close(IoDIRP(io));
if (!(IoDIRP(io) = PerlDir_open(dirname)))
if (!(IoFLAGS(io) & IOf_UNTAINT))
SvTAINTED_on(sv);
#endif
- XPUSHs(sv_2mortal(sv));
- }
- while (gimme == G_ARRAY);
+ mXPUSHs(sv);
+ } while (gimme == G_ARRAY);
if (!dp && gimme != G_ARRAY)
goto nope;
PP(pp_wait)
{
-#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
dVAR; dSP; dTARGET;
Pid_t childpid;
int argflags;
PP(pp_waitpid)
{
-#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
dVAR; dSP; dTARGET;
const int optype = POPi;
const Pid_t pid = TOPi;
PP(pp_system)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+#if defined(__LIBCATAMOUNT__)
+ PL_statusvalue = -1;
+ SP = ORIGMARK;
+ XPUSHi(-1);
+#else
I32 value;
int result;
SP = ORIGMARK;
if (did_pipes) {
int errkid;
- int n = 0, n1;
+ unsigned n = 0;
+ SSize_t n1;
while (n < sizeof(int)) {
n1 = PerlLIO_read(pp[0],
result = 0;
if (PL_op->op_flags & OPf_STACKED) {
SV * const really = *++MARK;
-# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
+# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
value = (I32)do_aspawn(really, MARK, SP);
# else
value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
# endif
}
else if (SP - MARK != 1) {
-# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
+# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
value = (I32)do_aspawn(NULL, MARK, SP);
# else
value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
do_execfree();
SP = ORIGMARK;
XPUSHi(result ? value : STATUS_CURRENT);
-#endif /* !FORK or VMS */
+#endif /* !FORK or VMS or OS/2 */
+#endif
RETURN;
}
/* is returned. */
#endif
- PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
+ mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
if (GIMME == G_ARRAY) {
- PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
- PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
- PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
+ mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
+ mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
+ mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
}
RETURN;
#else
# ifdef PERL_MICRO
dSP;
- PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ mPUSHn(0.0);
EXTEND(SP, 4);
if (GIMME == G_ARRAY) {
- PUSHs(sv_2mortal(newSVnv((NV)0.0)));
- PUSHs(sv_2mortal(newSVnv((NV)0.0)));
- PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ mPUSHn(0.0);
+ mPUSHn(0.0);
+ mPUSHn(0.0);
}
RETURN;
# else
tmbuf->tm_min,
tmbuf->tm_sec,
tmbuf->tm_year + 1900);
- PUSHs(sv_2mortal(tsv));
+ mPUSHs(tsv);
}
else if (tmbuf) {
EXTEND(SP, 9);
EXTEND_MORTAL(9);
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
+ mPUSHi(tmbuf->tm_sec);
+ mPUSHi(tmbuf->tm_min);
+ mPUSHi(tmbuf->tm_hour);
+ mPUSHi(tmbuf->tm_mday);
+ mPUSHi(tmbuf->tm_mon);
+ mPUSHi(tmbuf->tm_year);
+ mPUSHi(tmbuf->tm_wday);
+ mPUSHi(tmbuf->tm_yday);
+ mPUSHi(tmbuf->tm_isdst);
}
RETURN;
}
static SV *
S_space_join_names_mortal(pTHX_ char *const *array)
{
- SV *target = sv_2mortal(newSVpvs(""));
+ SV *target;
+
+ PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
if (array && *array) {
+ target = newSVpvs_flags("", SVs_TEMP);
while (1) {
sv_catpv(target, *array);
if (!*++array)
break;
sv_catpvs(target, " ");
}
+ } else {
+ target = sv_mortalcopy(&PL_sv_no);
}
return target;
}
const int addrtype = POPi;
SV * const addrsv = POPs;
STRLEN addrlen;
- Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
+ const char *addr = (char *)SvPVbyte(addrsv, addrlen);
hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
#else
}
if (hent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, (char*)hent->h_name);
- PUSHs(S_space_join_names_mortal(aTHX_ hent->h_aliases));
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setiv(sv, (IV)hent->h_addrtype);
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ mPUSHs(newSVpv((char*)hent->h_name, 0));
+ PUSHs(space_join_names_mortal(hent->h_aliases));
+ mPUSHi(hent->h_addrtype);
len = hent->h_length;
- sv_setiv(sv, (IV)len);
+ mPUSHi(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);
+ mXPUSHp(*elem, len);
}
#else
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
if (hent->h_addr)
- sv_setpvn(sv, hent->h_addr, len);
+ mPUSHp(hent->h_addr, len);
+ else
+ PUSHs(sv_mortalcopy(&PL_sv_no));
#endif /* h_addr */
}
RETURN;
}
if (nent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, nent->n_name);
- PUSHs(S_space_join_names_mortal(aTHX_ nent->n_aliases));
- 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);
+ mPUSHs(newSVpv(nent->n_name, 0));
+ PUSHs(space_join_names_mortal(nent->n_aliases));
+ mPUSHi(nent->n_addrtype);
+ mPUSHi(nent->n_net);
}
RETURN;
}
if (pent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, pent->p_name);
- PUSHs(S_space_join_names_mortal(aTHX_ pent->p_aliases));
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setiv(sv, (IV)pent->p_proto);
+ mPUSHs(newSVpv(pent->p_name, 0));
+ PUSHs(space_join_names_mortal(pent->p_aliases));
+ mPUSHi(pent->p_proto);
}
RETURN;
}
if (sent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, sent->s_name);
- PUSHs(S_space_join_names_mortal(aTHX_ sent->s_aliases));
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ mPUSHs(newSVpv(sent->s_name, 0));
+ PUSHs(space_join_names_mortal(sent->s_aliases));
#ifdef HAS_NTOHS
- sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
+ mPUSHi(PerlSock_ntohs(sent->s_port));
#else
- sv_setiv(sv, (IV)(sent->s_port));
+ mPUSHi(sent->s_port);
#endif
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, sent->s_proto);
+ mPUSHs(newSVpv(sent->s_proto, 0));
}
RETURN;
{
#ifdef HAS_SETNETENT
dVAR; dSP;
- PerlSock_setnetent(TOPi);
+ (void)PerlSock_setnetent(TOPi);
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "setnetent");
{
#ifdef HAS_SETPROTOENT
dVAR; dSP;
- PerlSock_setprotoent(TOPi);
+ (void)PerlSock_setprotoent(TOPi);
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "setprotoent");
{
#ifdef HAS_SETSERVENT
dVAR; dSP;
- PerlSock_setservent(TOPi);
+ (void)PerlSock_setservent(TOPi);
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "setservent");
}
if (pwent) {
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, pwent->pw_name);
+ mPUSHs(newSVpv(pwent->pw_name, 0));
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- SvPOK_off(sv);
+ sv = newSViv(0);
+ mPUSHs(sv);
/* 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,
SvTAINTED_on(sv);
# endif
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
# if Uid_t_sign <= 0
- sv_setiv(sv, (IV)pwent->pw_uid);
+ mPUSHi(pwent->pw_uid);
# else
- sv_setuv(sv, (UV)pwent->pw_uid);
+ mPUSHu(pwent->pw_uid);
# endif
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
# if Uid_t_sign <= 0
- sv_setiv(sv, (IV)pwent->pw_gid);
+ mPUSHi(pwent->pw_gid);
# else
- sv_setuv(sv, (UV)pwent->pw_gid);
+ mPUSHu(pwent->pw_gid);
# endif
/* pw_change, pw_quota, and pw_age are mutually exclusive--
* because of the poor interface of the Perl getpw*(),
* not because there's some standard/convention saying so.
* 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);
+ mPUSHi(pwent->pw_change);
# else
# ifdef PWQUOTA
- sv_setiv(sv, (IV)pwent->pw_quota);
+ mPUSHi(pwent->pw_quota);
# else
# ifdef PWAGE
- sv_setpv(sv, pwent->pw_age);
+ mPUSHs(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);
+ mPUSHs(newSVpv(pwent->pw_class, 0));
# else
# ifdef PWCOMMENT
- sv_setpv(sv, pwent->pw_comment);
+ mPUSHs(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 = 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);
+ mPUSHs(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);
+ mPUSHi(pwent->pw_expire);
# endif
}
RETURN;
}
if (grent) {
- SV *sv;
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
- sv_setpv(sv, grent->gr_name);
+ mPUSHs(newSVpv(grent->gr_name, 0));
- PUSHs(sv = sv_mortalcopy(&PL_sv_no));
#ifdef GRPASSWD
- sv_setpv(sv, grent->gr_passwd);
+ mPUSHs(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);
+ mPUSHi(grent->gr_gid);
#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
/* In UNICOS/mk (_CRAYMPP) the multithreading
* but the gr_mem is poisonous anyway.
* So yes, you cannot get the list of group
* members if building multithreaded in UNICOS/mk. */
- PUSHs(S_space_join_names_mortal(aTHX_ grent->gr_mem));
+ PUSHs(space_join_names_mortal(grent->gr_mem));
#endif
}